From 8a43565da5a1f5247d238e5ed8a1ad75f8288e60 Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Tue, 26 Oct 2021 14:53:36 -0600 Subject: [PATCH] refactor registry to include OS version filtering on the package index (#64) * refactor registry to include OS version filtering on the package index * remove commented code, clean up tests * removed unused types * remove disabled test * remove unused type * fix query parsing * remove unused code * more purging * MOAR PURGING * normalize data model, fix all type errors * rename get parameter --- package.yaml | 1 + src/Database/Marketplace.hs | 126 ++++++++---- src/Database/Queries.hs | 33 +-- src/Foundation.hs | 6 +- src/Handler/Apps.hs | 40 +--- src/Handler/Icons.hs | 5 - src/Handler/Marketplace.hs | 353 ++++++++++++-------------------- src/Handler/Types/Status.hs | 21 -- src/Handler/Version.hs | 4 - src/Lib/Error.hs | 16 -- src/Lib/Registry.hs | 59 ------ src/Lib/Ssl.hs | 8 +- src/Lib/SystemCtl.hs | 20 -- src/Lib/Types/AppIndex.hs | 180 ++++------------ src/Lib/Types/FileSystem.hs | 6 - src/Model.hs | 32 ++- src/Orphans/Yesod.hs | 13 -- src/Startlude.hs | 8 +- src/Util/Function.hs | 26 --- src/Util/Shared.hs | 1 - test/Handler/MarketplaceSpec.hs | 32 ++- 21 files changed, 304 insertions(+), 686 deletions(-) delete mode 100644 src/Lib/SystemCtl.hs delete mode 100644 src/Lib/Types/FileSystem.hs delete mode 100644 src/Orphans/Yesod.hs delete mode 100644 src/Util/Function.hs diff --git a/package.yaml b/package.yaml index c24e96c..4afcd1f 100644 --- a/package.yaml +++ b/package.yaml @@ -32,6 +32,7 @@ dependencies: - filepath - foreign-store - fsnotify + - http-api-data - http-types - interpolate - lens diff --git a/src/Database/Marketplace.hs b/src/Database/Marketplace.hs index 6660dd6..98b924d 100644 --- a/src/Database/Marketplace.hs +++ b/src/Database/Marketplace.hs @@ -4,61 +4,109 @@ module Database.Marketplace where +import Conduit ( ConduitT + , MonadResource + , MonadUnliftIO + , awaitForever + , yield + ) +import Database.Esqueleto.Experimental + ( (%) + , (&&.) + , (++.) + , (==.) + , Entity(entityKey, entityVal) + , SqlBackend + , (^.) + , desc + , from + , ilike + , in_ + , innerJoin + , on + , orderBy + , select + , selectSource + , val + , valList + , where_ + , (||.) + ) +import Database.Esqueleto.Experimental + ( (:&)(..) + , table + ) +import Lib.Types.AppIndex ( PkgId ) +import Lib.Types.Category +import Lib.Types.Emver ( Version ) +import Model import Startlude hiding ( (%) , from , on + , yield ) -import Database.Esqueleto.Experimental -import Lib.Types.Category -import Model -import qualified Database.Persist as P -import Data.HashMap.Strict -import Data.Version -import Data.Aeson -searchServices :: MonadIO m => Maybe CategoryTitle -> Int64 -> Int64 -> Text -> ReaderT SqlBackend m [P.Entity SApp] -searchServices Nothing pageItems offset' query = select $ do - service <- from $ table @SApp +searchServices :: (MonadResource m, MonadIO m) + => Maybe CategoryTitle + -> Text + -> ConduitT () (Entity PkgRecord) (ReaderT SqlBackend m) () +searchServices Nothing query = selectSource $ do + service <- from $ table @PkgRecord where_ - ( (service ^. SAppDescShort `ilike` (%) ++. val query ++. (%)) - ||. (service ^. SAppDescLong `ilike` (%) ++. val query ++. (%)) - ||. (service ^. SAppTitle `ilike` (%) ++. val query ++. (%)) + ( (service ^. PkgRecordDescShort `ilike` (%) ++. val query ++. (%)) + ||. (service ^. PkgRecordDescLong `ilike` (%) ++. val query ++. (%)) + ||. (service ^. PkgRecordTitle `ilike` (%) ++. val query ++. (%)) ) - orderBy [desc (service ^. SAppUpdatedAt)] - limit pageItems - offset offset' + orderBy [desc (service ^. PkgRecordUpdatedAt)] pure service -searchServices (Just category) pageItems offset' query = select $ do +searchServices (Just category) query = selectSource $ do services <- from (do - (service :& sc) <- + (service :& _ :& cat) <- from - $ table @SApp - `innerJoin` table @ServiceCategory - `on` (\(s :& sc) -> sc ^. ServiceCategoryServiceId ==. s ^. SAppId) - -- if there is a cateogry, only search in category - -- weight title, short, long (bitcoin should equal Bitcoin Core) + $ table @PkgRecord + `innerJoin` table @PkgCategory + `on` (\(s :& sc) -> sc ^. PkgCategoryPkgId ==. s ^. PkgRecordId) + `innerJoin` table @Category + `on` (\(_ :& sc :& cat) -> sc ^. PkgCategoryCategoryId ==. cat ^. CategoryId) + -- if there is a cateogry, only search in category + -- weight title, short, long (bitcoin should equal Bitcoin Core) where_ - $ sc - ^. ServiceCategoryCategoryName + $ cat + ^. CategoryName ==. val category - &&. ( (service ^. SAppDescShort `ilike` (%) ++. val query ++. (%)) - ||. (service ^. SAppDescLong `ilike` (%) ++. val query ++. (%)) - ||. (service ^. SAppTitle `ilike` (%) ++. val query ++. (%)) + &&. ( (service ^. PkgRecordDescShort `ilike` (%) ++. val query ++. (%)) + ||. (service ^. PkgRecordDescLong `ilike` (%) ++. val query ++. (%)) + ||. (service ^. PkgRecordTitle `ilike` (%) ++. val query ++. (%)) ) pure service ) - orderBy [desc (services ^. SAppUpdatedAt)] - limit pageItems - offset offset' + orderBy [desc (services ^. PkgRecordUpdatedAt)] pure services -newtype VersionsWithReleaseNotes = VersionsWithReleaseNotes (HashMap Version Text) deriving (Eq, Show, Generic) -instance FromJSON VersionsWithReleaseNotes -instance PersistField VersionsWithReleaseNotes where - fromPersistValue = fromPersistValueJSON - toPersistValue = PersistText . show +getPkgData :: (MonadResource m, MonadIO m) => [PkgId] -> ConduitT () (Entity PkgRecord) (ReaderT SqlBackend m) () +getPkgData pkgs = selectSource $ do + pkgData <- from $ table @PkgRecord + where_ (pkgData ^. PkgRecordId `in_` valList (PkgRecordKey <$> pkgs)) + pure pkgData --- in progress attempt to do postgres aggregation with raw sql in esqueleto --- getServiceVersionsWithReleaseNotes :: MonadIO m => Text -> ReaderT SqlBackend m (Entity SApp) --- getServiceVersionsWithReleaseNotes appId = rawSql "SELECT ??, json_agg(json_build_object(v.number, v.release_notes)) as versions FROM s_app s LEFT JOIN version v ON v.app_id = s.id WHERE s.app_id = ? GROUP BY s.id;" [PersistText appId] +zipVersions :: MonadUnliftIO m + => ConduitT (Entity PkgRecord) (Entity PkgRecord, [Entity VersionRecord]) (ReaderT SqlBackend m) () +zipVersions = awaitForever $ \i -> do + let appDbId = entityKey i + res <- lift $ select $ do + v <- from $ table @VersionRecord + where_ $ v ^. VersionRecordPkgId ==. val appDbId + pure v + yield (i, res) + +filterOsCompatible :: Monad m + => (Version -> Bool) + -> ConduitT + (Entity PkgRecord, [Entity VersionRecord]) + (Entity PkgRecord, [Entity VersionRecord]) + m + () +filterOsCompatible p = awaitForever $ \(app, versions) -> do + let compatible = filter (p . versionRecordOsVersion . entityVal) versions + when (not $ null compatible) $ yield (app, compatible) diff --git a/src/Database/Queries.hs b/src/Database/Queries.hs index a2decd5..3cc58ac 100644 --- a/src/Database/Queries.hs +++ b/src/Database/Queries.hs @@ -9,32 +9,15 @@ import Lib.Types.AppIndex import Lib.Types.Emver import Model import Orphans.Emver ( ) -import Startlude +import Startlude hiding ( get ) -fetchApp :: MonadIO m => PkgId -> ReaderT SqlBackend m (Maybe (Entity SApp)) -fetchApp appId = selectFirst [SAppAppId ==. appId] [] +fetchApp :: MonadIO m => PkgId -> ReaderT SqlBackend m (Maybe PkgRecord) +fetchApp = get . PkgRecordKey -fetchAppVersion :: MonadIO m => Version -> Key SApp -> ReaderT SqlBackend m (Maybe (Entity SVersion)) -fetchAppVersion appVersion appId = selectFirst [SVersionNumber ==. appVersion, SVersionAppId ==. appId] [] +fetchAppVersion :: MonadIO m => PkgId -> Version -> ReaderT SqlBackend m (Maybe VersionRecord) +fetchAppVersion pkgId version = get (VersionRecordKey (PkgRecordKey pkgId) version) -createApp :: MonadIO m => PkgId -> StoreApp -> ReaderT SqlBackend m (Maybe (Key SApp)) -createApp appId StoreApp {..} = do +createMetric :: MonadIO m => PkgId -> Version -> ReaderT SqlBackend m () +createMetric appId version = do time <- liftIO getCurrentTime - insertUnique $ SApp time Nothing storeAppTitle appId storeAppDescShort storeAppDescLong storeAppIconType - -createAppVersion :: MonadIO m => Key SApp -> VersionInfo -> Text -> ReaderT SqlBackend m (Maybe (Key SVersion)) -createAppVersion sId VersionInfo {..} arch = do - time <- liftIO getCurrentTime - insertUnique $ SVersion time - Nothing - sId - versionInfoVersion - versionInfoReleaseNotes - versionInfoOsRequired - versionInfoOsRecommended - (Just arch) - -createMetric :: MonadIO m => Key SApp -> Key SVersion -> ReaderT SqlBackend m () -createMetric appId versionId = do - time <- liftIO getCurrentTime - insert_ $ Metric time appId versionId + insert_ $ Metric time (PkgRecordKey appId) (VersionRecordKey (PkgRecordKey appId) version) diff --git a/src/Foundation.hs b/src/Foundation.hs index 29632a6..44e1393 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -6,6 +6,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-orphans #-} module Foundation where import Startlude hiding ( Handler ) @@ -64,12 +65,15 @@ instance Has PkgRepo RegistryCtx where let repo = f $ extract ctx settings = (appSettings ctx) { resourcesDir = pkgRepoFileRoot repo, staticBinDir = pkgRepoAppMgrBin repo } in ctx { appSettings = settings } -instance Has PkgRepo (HandlerData RegistryCtx RegistryCtx) where +instance Has a r => Has a (HandlerData r r) where extract = extract . rheSite . handlerEnv update f r = let ctx = update f (rheSite $ handlerEnv r) rhe = (handlerEnv r) { rheSite = ctx, rheChild = ctx } in r { handlerEnv = rhe } +instance Has AppSettings RegistryCtx where + extract = appSettings + update f ctx = ctx { appSettings = f (appSettings ctx) } diff --git a/src/Handler/Apps.hs b/src/Handler/Apps.hs index 7ef0b06..304bafa 100644 --- a/src/Handler/Apps.hs +++ b/src/Handler/Apps.hs @@ -11,16 +11,8 @@ module Handler.Apps where import Startlude hiding ( Handler ) -import Control.Monad.Logger ( logError - , logInfo - ) -import Data.Aeson ( ToJSON - , encode - ) -import qualified Data.Attoparsec.Text as Atto -import qualified Data.ByteString.Lazy as BS +import Control.Monad.Logger ( logError ) import qualified Data.Text as T -import Database.Persist ( Entity(entityKey) ) import qualified GHC.Show ( Show(..) ) import Network.HTTP.Types ( status404 ) import System.FilePath ( (<.>) @@ -34,7 +26,6 @@ import Yesod.Core ( TypedContent , sendResponseStatus , typeJson , typeOctet - , waiRequest ) import Yesod.Persist.Core ( YesodPersist(runDB) ) @@ -55,37 +46,17 @@ import Lib.PkgRepository ( getBestVersion ) import Lib.Registry ( S9PK ) import Lib.Types.AppIndex ( PkgId(PkgId) ) -import Lib.Types.Emver ( Version - , parseVersion - ) -import Network.Wai ( Request(requestHeaderUserAgent) ) +import Lib.Types.Emver ( Version ) import Util.Shared ( addPackageHeader , getVersionSpecFromQuery , orThrow ) -pureLog :: Show a => a -> Handler a -pureLog = liftA2 (*>) ($logInfo . show) pure - -logRet :: ToJSON a => Handler a -> Handler a -logRet = (>>= liftA2 (*>) ($logInfo . decodeUtf8 . BS.toStrict . encode) pure) - data FileExtension = FileExtension FilePath (Maybe String) instance Show FileExtension where show (FileExtension f Nothing ) = f show (FileExtension f (Just e)) = f <.> e -userAgentOsVersionParser :: Atto.Parser Version -userAgentOsVersionParser = do - void $ (Atto.string "EmbassyOS" <|> Atto.string "AmbassadorOS" <|> Atto.string "MeshOS") *> Atto.char '/' - parseVersion - -getEmbassyOsVersion :: Handler (Maybe Version) -getEmbassyOsVersion = userAgentOsVersion - where - userAgentOsVersion = - (hush . Atto.parseOnly userAgentOsVersionParser . decodeUtf8 <=< requestHeaderUserAgent) <$> waiRequest - getAppManifestR :: PkgId -> Handler TypedContent getAppManifestR pkg = do versionSpec <- getVersionSpecFromQuery @@ -116,12 +87,11 @@ recordMetrics pkg appVersion = do Nothing -> do $logError $ [i|#{pkg} not found in database|] notFound - Just a -> do - let appKey' = entityKey a - existingVersion <- runDB $ fetchAppVersion appVersion appKey' + Just _ -> do + existingVersion <- runDB $ fetchAppVersion pkg appVersion case existingVersion of Nothing -> do $logError $ [i|#{pkg}@#{appVersion} not found in database|] notFound - Just v -> runDB $ createMetric (entityKey a) (entityKey v) + Just _ -> runDB $ createMetric pkg appVersion diff --git a/src/Handler/Icons.hs b/src/Handler/Icons.hs index 6333bd7..25cee0d 100644 --- a/src/Handler/Icons.hs +++ b/src/Handler/Icons.hs @@ -32,11 +32,6 @@ data IconType = PNG | JPG | JPEG | SVG instance ToJSON IconType instance FromJSON IconType --- >>> readMaybe $ ixt :: Maybe IconType --- Just PNG -ixt :: Text -ixt = toS $ toUpper <$> drop 1 ".png" - getIconsR :: PkgId -> Handler TypedContent getIconsR pkg = do spec <- getVersionSpecFromQuery diff --git a/src/Handler/Marketplace.hs b/src/Handler/Marketplace.hs index 9f3e566..979c33c 100644 --- a/src/Handler/Marketplace.hs +++ b/src/Handler/Marketplace.hs @@ -1,18 +1,16 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE DeriveAnyClass #-} module Handler.Marketplace where -import Startlude hiding ( Handler +import Startlude hiding ( Any + , Handler + , ask , from , on , sortOn @@ -20,10 +18,17 @@ import Startlude hiding ( Handler import Conduit ( (.|) , awaitForever + , dropC + , mapC , runConduit + , sinkList , sourceFile + , takeC ) import Control.Monad.Except.CoHas ( liftEither ) +import Control.Monad.Reader.Has ( Has + , ask + ) import Control.Parallel.Strategies ( parMap , rpar ) @@ -51,32 +56,29 @@ import Data.String.Interpolate.IsString ( i ) import qualified Data.Text as T import Database.Esqueleto.Experimental - ( (&&.) - , (:&)((:&)) + ( (:&)((:&)) , (==.) - , (?.) , Entity(entityKey, entityVal) - , PersistEntity(Key) , SqlBackend , Value(unValue) , (^.) , desc , from - , groupBy + , in_ , innerJoin - , just - , leftJoin - , limit , on , orderBy , select - , selectOne , table , val + , valList , where_ ) -import Database.Esqueleto.PostgreSQL ( arrayAggDistinct ) -import Database.Marketplace ( searchServices ) +import Database.Marketplace ( filterOsCompatible + , getPkgData + , searchServices + , zipVersions + ) import qualified Database.Persist as P import Foundation ( Handler , RegistryCtx(appSettings) @@ -89,19 +91,21 @@ import Lib.Types.AppIndex ( PkgId(PkgId) , VersionInfo(..) ) import Lib.Types.AppIndex ( ) -import Lib.Types.Category ( CategoryTitle(FEATURED) ) +import Lib.Types.Category ( CategoryTitle(..) ) import Lib.Types.Emver ( (<||) , Version - , VersionRange + , VersionRange(Any) + , parseRange , parseVersion , satisfies ) import Model ( Category(..) , EntityField(..) + , Key(PkgRecordKey, unPkgRecordKey) , OsVersion(..) - , SApp(..) - , SVersion(..) - , ServiceCategory + , PkgCategory + , PkgRecord(..) + , VersionRecord(..) ) import Network.HTTP.Types ( status400 , status404 @@ -110,17 +114,10 @@ import Protolude.Unsafe ( unsafeFromJust ) import Settings ( AppSettings(registryHostname, resourcesDir) ) import System.Directory ( getFileSize ) import System.FilePath ( () ) -import UnliftIO.Async ( concurrently - , mapConcurrently - ) +import UnliftIO.Async ( mapConcurrently ) import UnliftIO.Directory ( listDirectory ) -import Util.Shared ( getVersionSpecFromQuery - , orThrow - ) -import Yesod.Core ( HandlerFor - , MonadLogger - , MonadResource - , MonadUnliftIO +import Util.Shared ( getVersionSpecFromQuery ) +import Yesod.Core ( MonadResource , ToContent(..) , ToTypedContent(..) , TypedContent @@ -142,7 +139,6 @@ newtype CategoryRes = CategoryRes { categories :: [CategoryTitle] } deriving (Show, Generic) instance ToJSON CategoryRes -instance FromJSON CategoryRes instance ToContent CategoryRes where toContent = toContent . toJSON instance ToTypedContent CategoryRes where @@ -176,10 +172,6 @@ instance ToJSON ServiceRes where , "versions" .= serviceResVersions , "dependency-metadata" .= serviceResDependencyInfo ] -instance ToContent ServiceRes where - toContent = toContent . toJSON -instance ToTypedContent ServiceRes where - toTypedContent = toTypedContent . toJSON data DependencyInfo = DependencyInfo { dependencyInfoTitle :: PkgId , dependencyInfoIcon :: URL @@ -188,40 +180,6 @@ data DependencyInfo = DependencyInfo instance ToJSON DependencyInfo where toJSON DependencyInfo {..} = object ["icon" .= dependencyInfoIcon, "title" .= dependencyInfoTitle] -data ServiceListRes = ServiceListRes - { serviceListResCategories :: [CategoryTitle] - , serviceListResServices :: [ServiceAvailable] - } - deriving Show -instance ToJSON ServiceListRes where - toJSON ServiceListRes {..} = - object ["categories" .= serviceListResCategories, "services" .= serviceListResServices] -instance ToContent ServiceListRes where - toContent = toContent . toJSON -instance ToTypedContent ServiceListRes where - toTypedContent = toTypedContent . toJSON - -data ServiceAvailable = ServiceAvailable - { serviceAvailableId :: PkgId - , serviceAvailableTitle :: Text - , serviceAvailableVersion :: Version - , serviceAvailableIcon :: URL - , serviceAvailableDescShort :: Text - } - deriving Show -instance ToJSON ServiceAvailable where - toJSON ServiceAvailable {..} = object - [ "id" .= serviceAvailableId - , "title" .= serviceAvailableTitle - , "version" .= serviceAvailableVersion - , "icon" .= serviceAvailableIcon - , "descriptionShort" .= serviceAvailableDescShort - ] -instance ToContent ServiceAvailable where - toContent = toContent . toJSON -instance ToTypedContent ServiceAvailable where - toTypedContent = toTypedContent . toJSON - newtype ServiceAvailableRes = ServiceAvailableRes [ServiceRes] deriving (Generic) instance ToJSON ServiceAvailableRes @@ -241,8 +199,8 @@ data OrderArrangement = ASC | DESC deriving (Eq, Show, Read) data ServiceListDefaults = ServiceListDefaults { serviceListOrder :: OrderArrangement - , serviceListPageLimit :: Int64 -- the number of items per page - , serviceListPageNumber :: Int64 -- the page you are on + , serviceListPageLimit :: Int -- the number of items per page + , serviceListPageNumber :: Int -- the page you are on , serviceListCategory :: Maybe CategoryTitle , serviceListQuery :: Text } @@ -305,11 +263,8 @@ getReleaseNotesR = do case lookup "id" getParameters of Nothing -> sendResponseStatus status400 (InvalidParamsE "get:id" "") Just package -> do - (service, _) <- runDB $ fetchLatestApp (PkgId package) `orThrow` sendResponseStatus - status404 - (NotFoundE $ show package) - (_, mappedVersions) <- fetchAllAppVersions (entityKey service) - pure mappedVersions + (_, notes) <- fetchAllAppVersions (PkgId package) + pure notes getEosR :: Handler TypedContent getEosR = do @@ -332,50 +287,70 @@ getVersionLatestR = do case lookup "ids" getParameters of Nothing -> sendResponseStatus status400 (InvalidParamsE "get:ids" "") Just packages -> case eitherDecode $ BS.fromStrict $ encodeUtf8 packages of - Left _ -> sendResponseStatus status400 (InvalidParamsE "get:ids" packages) - Right (p :: [PkgId]) -> do - let packageList :: [(PkgId, Maybe Version)] = (, Nothing) <$> p + Left _ -> sendResponseStatus status400 (InvalidParamsE "get:ids" packages) + Right p -> do + let packageList = (, Nothing) <$> p found <- runDB $ traverse fetchLatestApp $ fst <$> packageList pure $ VersionLatestRes $ HM.union ( HM.fromList - $ (\v -> (sAppAppId $ entityVal $ fst v, Just $ sVersionNumber $ entityVal $ snd v)) + $ (\v -> + (unPkgRecordKey . entityKey $ fst v, Just $ versionRecordNumber $ entityVal $ snd v) + ) <$> catMaybes found ) $ HM.fromList packageList getPackageListR :: Handler ServiceAvailableRes getPackageListR = do - pkgIds <- getPkgIdsQuery - case pkgIds of + osPredicate <- getOsVersionQuery <&> \case + Nothing -> const True + Just v -> flip satisfies v + pkgIds <- getPkgIdsQuery + filteredServices <- case pkgIds of Nothing -> do -- query for all - category <- getCategoryQuery - page <- getPageQuery - limit' <- getLimitQuery - query <- T.strip . fromMaybe (serviceListQuery defaults) <$> lookupGetParam "query" - filteredServices <- runDB $ searchServices category limit' ((page - 1) * limit') query - let filteredServices' = sAppAppId . entityVal <$> filteredServices - settings <- getsYesod appSettings - packageMetadata <- runDB $ fetchPackageMetadata - serviceDetailResult <- mapConcurrently (getServiceDetails settings packageMetadata Nothing) - filteredServices' - let (_, services) = partitionEithers serviceDetailResult - pure $ ServiceAvailableRes services - + category <- getCategoryQuery + page <- getPageQuery + limit' <- getLimitQuery + query <- T.strip . fromMaybe (serviceListQuery defaults) <$> lookupGetParam "query" + runDB + $ runConduit + $ searchServices category query + .| zipVersions + .| filterOsCompatible osPredicate + -- pages start at 1 for some reason. TODO: make pages start at 0 + .| (dropC (limit' * (page - 1)) *> takeC limit') + .| sinkList Just packages -> do - -- for each item in list get best available from version range - settings <- getsYesod appSettings - -- @TODO fix _ error - packageMetadata <- runDB $ fetchPackageMetadata - availableServicesResult <- traverse (getPackageDetails packageMetadata) packages - let (_, availableServices) = partitionEithers availableServicesResult - serviceDetailResult <- mapConcurrently (uncurry $ getServiceDetails settings packageMetadata) - availableServices - -- @TODO fix _ error - let (_, services) = partitionEithers serviceDetailResult - pure $ ServiceAvailableRes services + -- for each item in list get best available from version range + let vMap = (packageVersionId &&& packageVersionVersion) <$> packages + runDB + . runConduit + $ getPkgData (packageVersionId <$> packages) + .| zipVersions + .| mapC + (\(a, vs) -> + let spec = fromMaybe Any $ lookup (unPkgRecordKey $ entityKey a) vMap + in (a, filter ((<|| spec) . versionRecordNumber . entityVal) vs) + ) + .| filterOsCompatible osPredicate + .| sinkList + let keys = unPkgRecordKey . entityKey . fst <$> filteredServices + cats <- runDB $ fetchAppCategories keys + let vers = + filteredServices + <&> first (unPkgRecordKey . entityKey) + <&> second (sortOn Down . fmap (versionRecordNumber . entityVal)) + & HM.fromListWith (++) + let packageMetadata = HM.intersectionWith (,) vers (categoryName <<$>> cats) + serviceDetailResult <- mapConcurrently (flip (getServiceDetails packageMetadata) Nothing) + (unPkgRecordKey . entityKey . fst <$> filteredServices) + let services = snd $ partitionEithers serviceDetailResult + pure $ ServiceAvailableRes services + + where defaults = ServiceListDefaults { serviceListOrder = DESC , serviceListPageLimit = 20 @@ -401,7 +376,7 @@ getPackageListR = do $logWarn (show e) sendResponseStatus status400 e Just t -> pure $ Just t - getPageQuery :: Handler Int64 + getPageQuery :: Handler Int getPageQuery = lookupGetParam "page" >>= \case Nothing -> pure $ serviceListPageNumber defaults Just p -> case readMaybe p of @@ -412,7 +387,7 @@ getPackageListR = do Just t -> pure $ case t of 0 -> 1 -- disallow page 0 so offset is not negative _ -> t - getLimitQuery :: Handler Int64 + getLimitQuery :: Handler Int getLimitQuery = lookupGetParam "per-page" >>= \case Nothing -> pure $ serviceListPageLimit defaults Just pp -> case readMaybe pp of @@ -421,31 +396,23 @@ getPackageListR = do $logWarn (show e) sendResponseStatus status400 e Just l -> pure l - getPackageDetails :: MonadIO m - => (HM.HashMap PkgId ([Version], [CategoryTitle])) - -> PackageVersion - -> m (Either Text ((Maybe Version), PkgId)) - getPackageDetails metadata pv = do - let appId = packageVersionId pv - let spec = packageVersionVersion pv - pacakgeMetadata <- case HM.lookup appId metadata of - Nothing -> throwIO $ NotFoundE [i|dependency metadata for #{appId} not found.|] - Just m -> pure m - -- get best version from VersionRange of dependency - let satisfactory = filter (<|| spec) (fst pacakgeMetadata) - let best = getMax <$> foldMap (Just . Max) satisfactory - case best of - Nothing -> pure $ Left $ [i|Best version could not be found for #{appId} with spec #{spec}|] - Just v -> do - pure $ Right (Just v, appId) + getOsVersionQuery :: Handler (Maybe VersionRange) + getOsVersionQuery = lookupGetParam "eos-version-range" >>= \case + Nothing -> pure Nothing + Just osv -> case Atto.parseOnly parseRange osv of + Left _ -> do + let e = InvalidParamsE "get:eos-version-range" osv + $logWarn (show e) + sendResponseStatus status400 e + Right v -> pure $ Just v -getServiceDetails :: (MonadIO m, MonadResource m) - => AppSettings - -> (HM.HashMap PkgId ([Version], [CategoryTitle])) - -> Maybe Version +getServiceDetails :: (MonadIO m, MonadResource m, MonadReader r m, Has AppSettings r) + => (HM.HashMap PkgId ([Version], [CategoryTitle])) -> PkgId + -> Maybe Version -> m (Either S9Error ServiceRes) -getServiceDetails settings metadata maybeVersion pkg = runExceptT $ do +getServiceDetails metadata pkg maybeVersion = runExceptT $ do + settings <- ask packageMetadata <- case HM.lookup pkg metadata of Nothing -> liftEither . Left $ NotFoundE [i|#{pkg} not found.|] Just m -> pure m @@ -494,117 +461,49 @@ mapDependencyMetadata domain metadata (appId, depInfo) = do } ) -fetchAllAppVersions :: Key SApp -> HandlerFor RegistryCtx ([VersionInfo], ReleaseNotes) +fetchAllAppVersions :: PkgId -> Handler ([VersionInfo], ReleaseNotes) fetchAllAppVersions appId = do - entityAppVersions <- runDB $ P.selectList [SVersionAppId P.==. appId] [] + 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 :: [SVersion] -> [VersionInfo] + mapSVersionToVersionInfo :: [VersionRecord] -> [VersionInfo] mapSVersionToVersionInfo sv = do - (\v -> VersionInfo { versionInfoVersion = sVersionNumber v - , versionInfoReleaseNotes = sVersionReleaseNotes v - , versionInfoDependencies = HM.empty - , versionInfoOsRequired = sVersionOsVersionRequired v - , versionInfoOsRecommended = sVersionOsVersionRecommended v - , versionInfoInstallAlert = Nothing + (\v -> VersionInfo { versionInfoVersion = versionRecordNumber v + , versionInfoReleaseNotes = versionRecordReleaseNotes v + , versionInfoDependencies = HM.empty + , versionInfoOsVersion = versionRecordOsVersion v + , versionInfoInstallAlert = Nothing } ) <$> sv -fetchMostRecentAppVersions :: MonadIO m => Key SApp -> ReaderT SqlBackend m [Entity SVersion] -fetchMostRecentAppVersions appId = sortResults $ select $ do - version <- from $ table @SVersion - where_ (version ^. SVersionAppId ==. val appId) - limit 1 - pure version - where sortResults = fmap $ sortOn (Down . sVersionNumber . entityVal) -fetchLatestApp :: MonadIO m => PkgId -> ReaderT SqlBackend m (Maybe (P.Entity SApp, P.Entity SVersion)) +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 @SApp - `innerJoin` table @SVersion - `on` (\(service :& version) -> service ^. SAppId ==. version ^. SVersionAppId) - where_ (service ^. SAppAppId ==. val appId) + $ 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 . sVersionNumber . entityVal . snd) + where sortResults = fmap $ sortOn (Down . versionRecordNumber . entityVal . snd) -fetchLatestAppAtVersion :: MonadIO m - => PkgId - -> Version - -> ReaderT SqlBackend m (Maybe (P.Entity SApp, P.Entity SVersion)) -fetchLatestAppAtVersion appId version' = selectOne $ do - (service :& version) <- - from - $ table @SApp - `innerJoin` table @SVersion - `on` (\(service :& version) -> service ^. SAppId ==. version ^. SVersionAppId) - where_ $ (service ^. SAppAppId ==. val appId) &&. (version ^. SVersionNumber ==. val version') - pure (service, version) - -fetchPackageMetadata :: (MonadLogger m, MonadUnliftIO m) - => ReaderT SqlBackend m (HM.HashMap PkgId ([Version], [CategoryTitle])) -fetchPackageMetadata = do - let categoriesQuery = select $ do - (service :& category) <- - from - $ table @SApp - `leftJoin` table @ServiceCategory - `on` (\(service :& category) -> - Database.Esqueleto.Experimental.just (service ^. SAppId) - ==. category - ?. ServiceCategoryServiceId - ) - Database.Esqueleto.Experimental.groupBy $ service ^. SAppAppId - pure (service ^. SAppAppId, arrayAggDistinct (category ?. ServiceCategoryCategoryName)) - let versionsQuery = select $ do - (service :& version) <- - from - $ table @SApp - `innerJoin` table @SVersion - `on` (\(service :& version) -> (service ^. SAppId) ==. version ^. SVersionAppId) - Database.Esqueleto.Experimental.groupBy $ (service ^. SAppAppId, version ^. SVersionNumber) - pure (service ^. SAppAppId, arrayAggDistinct (version ^. SVersionNumber)) - (categories, versions) <- UnliftIO.Async.concurrently categoriesQuery versionsQuery - let - c = foreach categories - $ \(appId, categories') -> (unValue appId, catMaybes $ fromMaybe [] (unValue categories')) - let v = foreach versions $ \(appId, versions') -> (unValue appId, fromMaybe [] (unValue versions')) - let vv = HM.fromListWithKey (\_ vers vers' -> (++) vers vers') v - pure $ HM.intersectionWith (\cts vers -> (vers, cts)) (HM.fromList c) (sortVersions vv) - where sortVersions = fmap $ sortOn Down - -fetchAppCategories :: MonadIO m => Key SApp -> ReaderT SqlBackend m [P.Entity ServiceCategory] -fetchAppCategories appId = select $ do - (categories :& service) <- - from - $ table @ServiceCategory - `innerJoin` table @SApp - `on` (\(sc :& s) -> sc ^. ServiceCategoryServiceId ==. s ^. SAppId) - where_ (service ^. SAppId ==. val appId) - pure categories - --- >>> encode hm --- "{\"0.2.0\":\"some notes\"}" -hm :: Data.Aeson.Value -hm = object [ t .= v | (k, v) <- [("0.2.0", "some notes") :: (Version, Text)], let (String t) = toJSON k ] - --- >>> encode rn --- "{\"0.2.0\":\"notes one\",\"0.3.0\":\"notes two\"}" -rn :: ReleaseNotes -rn = ReleaseNotes $ HM.fromList [("0.2.0", "notes one"), ("0.3.0", "notes two")] - --- >>> readMaybe $ cc :: Maybe CategoryTitle --- Just FEATURED -cc :: Text -cc = T.toUpper "featured" - --- >>> encode ccc --- "\"featured\"" -ccc :: CategoryTitle -ccc = FEATURED +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/Status.hs b/src/Handler/Types/Status.hs index 5c23e79..f155fd1 100644 --- a/src/Handler/Types/Status.hs +++ b/src/Handler/Types/Status.hs @@ -8,7 +8,6 @@ import Startlude hiding ( toLower ) import Data.Aeson import Yesod.Core.Content -import Data.Text import Lib.Types.Emver import Orphans.Emver ( ) @@ -26,23 +25,3 @@ instance ToContent (Maybe AppVersionRes) where toContent = toContent . toJSON instance ToTypedContent (Maybe AppVersionRes) where toTypedContent = toTypedContent . toJSON - --- status - nothing, available, instuctions --- version - semver string - -data SystemStatus = NOTHING | AVAILABLE | INSTRUCTIONS - deriving (Eq, Show) -instance ToJSON SystemStatus where - toJSON = String . toLower . show - -data OSVersionRes = OSVersionRes - { osVersionStatus :: SystemStatus - , osVersionVersion :: Version - } - deriving (Eq, Show) -instance ToJSON OSVersionRes where - toJSON OSVersionRes {..} = object ["status" .= osVersionStatus, "version" .= osVersionVersion] -instance ToContent OSVersionRes where - toContent = toContent . toJSON -instance ToTypedContent OSVersionRes where - toTypedContent = toTypedContent . toJSON diff --git a/src/Handler/Version.hs b/src/Handler/Version.hs index 6839bbf..b383ef3 100644 --- a/src/Handler/Version.hs +++ b/src/Handler/Version.hs @@ -19,14 +19,10 @@ import Lib.Error ( S9Error(NotFoundE) ) import Lib.PkgRepository ( getBestVersion ) import Lib.Types.AppIndex ( PkgId ) import Network.HTTP.Types.Status ( status404 ) -import Settings import Util.Shared ( getVersionSpecFromQuery , orThrow ) -getVersionR :: Handler AppVersionRes -getVersionR = AppVersionRes . registryVersion . appSettings <$> getYesod - getPkgVersionR :: PkgId -> Handler AppVersionRes getPkgVersionR pkg = do spec <- getVersionSpecFromQuery diff --git a/src/Lib/Error.hs b/src/Lib/Error.hs index 7a6b0c7..5c9e9a6 100644 --- a/src/Lib/Error.hs +++ b/src/Lib/Error.hs @@ -64,19 +64,3 @@ toStatus = \case NotFoundE _ -> status404 InvalidParamsE _ _ -> status400 AssetParseE _ _ -> status500 - - -handleS9ErrT :: MonadHandler m => S9ErrT m a -> m a -handleS9ErrT action = runExceptT action >>= \case - Left e -> toStatus >>= sendResponseStatus $ e - Right a -> pure a - -handleS9ErrNuclear :: MonadIO m => S9ErrT m a -> m a -handleS9ErrNuclear action = runExceptT action >>= \case - Left e -> throwIO e - Right a -> pure a - -errOnNothing :: MonadHandler m => Status -> Text -> Maybe a -> m a -errOnNothing status res entity = case entity of - Nothing -> sendResponseStatus status res - Just a -> pure a diff --git a/src/Lib/Registry.hs b/src/Lib/Registry.hs index 15f1c8d..81ba64d 100644 --- a/src/Lib/Registry.hs +++ b/src/Lib/Registry.hs @@ -2,71 +2,18 @@ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TemplateHaskell #-} module Lib.Registry where import Startlude -import qualified Data.Attoparsec.Text as Atto -import Data.HashMap.Lazy hiding ( mapMaybe ) import qualified GHC.Read ( Read(..) ) import qualified GHC.Show ( Show(..) ) -import System.Directory import System.FilePath import Yesod.Core -import Lib.Types.Emver - -type Registry = HashMap String (HashMap Version FilePath) - -newtype RegisteredAppVersion = RegisteredAppVersion { unRegisteredAppVersion :: (Version, FilePath) } deriving (Eq, Show) -data MaxVersion a = MaxVersion - { getMaxVersion :: (a, a -> Version) - } -instance Semigroup (MaxVersion a) where - (MaxVersion (a, f)) <> (MaxVersion (b, g)) = if f a > g b then MaxVersion (a, f) else MaxVersion (b, g) - --- retrieve all valid semver folder names with queried for file: rootDirectory/appId/[0.0.0 ...]/appId.extension --- @TODO move to db query after all appversions are seeded qith post 0.3.0 migration script -getAvailableAppVersions :: KnownSymbol a => FilePath -> Extension a -> IO [RegisteredAppVersion] -getAvailableAppVersions rootDirectory ext@(Extension appId) = do - versions <- mapMaybe (hush . Atto.parseOnly parseVersion . toS) <$> getSubDirectories (rootDirectory appId) - fmap catMaybes . for versions $ \v -> getVersionedFileFromDir rootDirectory ext v >>= \case - Nothing -> pure Nothing - Just appFile -> pure . Just $ RegisteredAppVersion (v, appFile) - where - getSubDirectories path = (fmap (fromRight []) . try @SomeException $ listDirectory path) - >>= filterM (doesDirectoryExist . (path )) - --- this works for both service versions and embassyOS versions -getMostRecentAppVersion :: KnownSymbol a => FilePath -> Extension a -> IO (Maybe RegisteredAppVersion) -getMostRecentAppVersion rootDirectory ext = do - allVersions <- liftIO $ getAvailableAppVersions rootDirectory ext - pure $ head $ sortOn (Down . fst . unRegisteredAppVersion) allVersions - --- /root/appId/version/appId.ext -getVersionedFileFromDir :: KnownSymbol a => FilePath -> Extension a -> Version -> IO (Maybe FilePath) -getVersionedFileFromDir rootDirectory ext@(Extension appId) v = - getUnversionedFileFromDir (rootDirectory appId show v) ext - --- /root/appId.ext -getUnversionedFileFromDir :: KnownSymbol a => FilePath -> Extension a -> IO (Maybe FilePath) -getUnversionedFileFromDir rootDirectory appExt = fmap (join . hush) . try @SomeException $ do - dirContents <- listDirectory rootDirectory - pure . fmap (rootDirectory ) $ find (== show appExt) dirContents - newtype Extension (a :: Symbol) = Extension String deriving (Eq) type S9PK = Extension "s9pk" -type SYS_EXTENSIONLESS = Extension "" -type PNG = Extension "png" -type SVG = Extension "svg" - -instance IsString (Extension a) where - fromString = Extension - -def :: Extension a -def = Extension "" extension :: KnownSymbol a => Extension a -> String extension = symbolVal @@ -80,12 +27,6 @@ instance KnownSymbol a => Read (Extension a) where other -> [ (Extension file, "") | ext' == "" <.> other ] where (file, ext') = splitExtension s -withPeriod :: String -> String -withPeriod word@(a : _) = case a of - '.' -> word - _ -> "." <> word -withPeriod word = word - instance KnownSymbol a => PathPiece (Extension a) where fromPathPiece = readMaybe . toS toPathPiece = show diff --git a/src/Lib/Ssl.hs b/src/Lib/Ssl.hs index b7de3ed..79713ad 100644 --- a/src/Lib/Ssl.hs +++ b/src/Lib/Ssl.hs @@ -2,13 +2,13 @@ {-# LANGUAGE RecordWildCards #-} module Lib.Ssl where - -import Startlude - -import Data.String.Interpolate.IsString import System.Directory import System.Process +import Data.String.Interpolate.IsString + +import Startlude + import Foundation import Settings diff --git a/src/Lib/SystemCtl.hs b/src/Lib/SystemCtl.hs deleted file mode 100644 index d661352..0000000 --- a/src/Lib/SystemCtl.hs +++ /dev/null @@ -1,20 +0,0 @@ -module Lib.SystemCtl where - -import Startlude hiding ( words ) -import Protolude.Unsafe - -import Data.String -import System.Process -import Text.Casing - -data ServiceAction = - StartService - | StopService - | RestartService - deriving (Eq, Show) - -toAction :: ServiceAction -> String -toAction = fmap toLower . unsafeHead . words . wordify . show - -systemCtl :: ServiceAction -> Text -> IO ExitCode -systemCtl action service = rawSystem "systemctl" [toAction action, toS service] diff --git a/src/Lib/Types/AppIndex.hs b/src/Lib/Types/AppIndex.hs index 40fad6f..8ebda17 100644 --- a/src/Lib/Types/AppIndex.hs +++ b/src/Lib/Types/AppIndex.hs @@ -1,38 +1,49 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralisedNewtypeDeriving #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE QuasiQuotes #-} - module Lib.Types.AppIndex where -import Startlude hiding ( Any ) - -import Control.Monad.Fail -import Data.Aeson -import qualified Data.HashMap.Strict as HM -import qualified Data.List.NonEmpty as NE +import Startlude +import Control.Monad ( fail ) +import Data.Aeson ( (.:) + , (.:?) + , FromJSON(..) + , FromJSONKey(..) + , ToJSON(..) + , ToJSONKey(..) + , withObject + ) import qualified Data.ByteString.Lazy as BS -import Data.Functor.Contravariant ( Contravariant(contramap) ) +import Data.Functor.Contravariant ( contramap ) +import qualified Data.HashMap.Strict as HM import Data.String.Interpolate.IsString --- import Model import qualified Data.Text as T -import Database.Persist.Postgresql -import qualified GHC.Read ( Read(..) ) -import qualified GHC.Show ( Show(..) ) -import Lib.Registry -import Lib.Types.Emver +import Database.Persist ( PersistField(..) + , PersistValue(PersistText) + , SqlType(..) + ) +import Database.Persist.Sql ( PersistFieldSql(sqlType) ) +import GHC.Read ( Read(readsPrec) ) +import Lib.Types.Emver ( Version + , VersionRange + ) import Orphans.Emver ( ) -import System.Directory -import Yesod - +import qualified Protolude.Base as P + ( Show(..) ) +import Web.HttpApiData ( FromHttpApiData + , ToHttpApiData + ) +import Yesod ( PathPiece(..) ) newtype PkgId = PkgId { unPkgId :: Text } - deriving (Eq) + deriving stock (Eq, Ord) + deriving newtype (FromHttpApiData, ToHttpApiData) instance IsString PkgId where fromString = PkgId . fromString -instance Show PkgId where +instance P.Show PkgId where show = toS . unPkgId instance Read PkgId where readsPrec _ s = [(PkgId $ toS s, "")] @@ -55,101 +66,15 @@ instance PersistFieldSql PkgId where instance PathPiece PkgId where fromPathPiece = fmap PkgId . fromPathPiece toPathPiece = unPkgId -instance ToContent PkgId where - toContent = toContent . toJSON -instance ToTypedContent PkgId where - toTypedContent = toTypedContent . toJSON - data VersionInfo = VersionInfo - { versionInfoVersion :: Version - , versionInfoReleaseNotes :: Text - , versionInfoDependencies :: HM.HashMap PkgId VersionRange - , versionInfoOsRequired :: VersionRange - , versionInfoOsRecommended :: VersionRange - , versionInfoInstallAlert :: Maybe Text + { versionInfoVersion :: Version + , versionInfoReleaseNotes :: Text + , versionInfoDependencies :: HM.HashMap PkgId VersionRange + , versionInfoOsVersion :: Version + , versionInfoInstallAlert :: Maybe Text } deriving (Eq, Show) -instance Ord VersionInfo where - compare = compare `on` versionInfoVersion - -instance FromJSON VersionInfo where - parseJSON = withObject "version info" $ \o -> do - versionInfoVersion <- o .: "version" - versionInfoReleaseNotes <- o .: "release-notes" - versionInfoDependencies <- o .:? "dependencies" .!= HM.empty - versionInfoOsRequired <- o .:? "os-version-required" .!= Any - versionInfoOsRecommended <- o .:? "os-version-recommended" .!= Any - versionInfoInstallAlert <- o .:? "install-alert" - pure VersionInfo { .. } - -instance ToJSON VersionInfo where - toJSON VersionInfo {..} = object - [ "version" .= versionInfoVersion - , "release-notes" .= versionInfoReleaseNotes - , "dependencies" .= versionInfoDependencies - , "os-version-required" .= versionInfoOsRequired - , "os-version-recommended" .= versionInfoOsRecommended - , "install-alert" .= versionInfoInstallAlert - ] - -data StoreApp = StoreApp - { storeAppTitle :: Text - , storeAppDescShort :: Text - , storeAppDescLong :: Text - , storeAppVersionInfo :: NonEmpty VersionInfo - , storeAppIconType :: Text - , storeAppTimestamp :: Maybe UTCTime - } - deriving Show - -instance ToJSON StoreApp where - toJSON StoreApp {..} = object - [ "title" .= storeAppTitle - , "icon-type" .= storeAppIconType - , "description" .= object ["short" .= storeAppDescShort, "long" .= storeAppDescLong] - , "version-info" .= storeAppVersionInfo - , "timestamp" .= storeAppTimestamp - ] -newtype AppManifest = AppManifest { unAppManifest :: HM.HashMap PkgId StoreApp} - deriving (Show) - -instance FromJSON AppManifest where - parseJSON = withObject "app details to seed" $ \o -> do - apps <- for (HM.toList o) $ \(appId', c) -> do - appId <- parseJSON $ String appId' - config <- parseJSON c - storeAppTitle <- config .: "title" - storeAppIconType <- config .: "icon-type" - storeAppDescShort <- config .: "description" >>= (.: "short") - storeAppDescLong <- config .: "description" >>= (.: "long") - storeAppVersionInfo <- config .: "version-info" >>= \case - [] -> fail "No Valid Version Info" - (x : xs) -> pure $ x :| xs - storeAppTimestamp <- config .:? "timestamp" - pure (appId, StoreApp { .. }) - return $ AppManifest (HM.fromList apps) -instance ToJSON AppManifest where - toJSON = toJSON . unAppManifest - -filterOsRequired :: Version -> StoreApp -> Maybe StoreApp -filterOsRequired av sa = case NE.filter ((av <||) . versionInfoOsRequired) (storeAppVersionInfo sa) of - [] -> Nothing - (x : xs) -> Just $ sa { storeAppVersionInfo = x :| xs } - -filterOsRecommended :: Version -> StoreApp -> Maybe StoreApp -filterOsRecommended av sa = case NE.filter ((av <||) . versionInfoOsRecommended) (storeAppVersionInfo sa) of - [] -> Nothing - (x : xs) -> Just $ sa { storeAppVersionInfo = x :| xs } - -addFileTimestamp :: KnownSymbol a => FilePath -> Extension a -> StoreApp -> Version -> IO (Maybe StoreApp) -addFileTimestamp appDir ext service v = do - getVersionedFileFromDir appDir ext v >>= \case - Nothing -> pure Nothing - Just file -> do - time <- getModificationTime file - pure $ Just service { storeAppTimestamp = Just time } - data ServiceDependencyInfo = ServiceDependencyInfo { serviceDependencyInfoOptional :: Maybe Text , serviceDependencyInfoVersion :: VersionRange @@ -164,27 +89,8 @@ instance FromJSON ServiceDependencyInfo where serviceDependencyInfoDescription <- o .:? "description" serviceDependencyInfoCritical <- o .: "critical" pure ServiceDependencyInfo { .. } -instance ToJSON ServiceDependencyInfo where - toJSON ServiceDependencyInfo {..} = object - [ "description" .= serviceDependencyInfoDescription - , "version" .= serviceDependencyInfoVersion - , "optional" .= serviceDependencyInfoOptional - , "critical" .= serviceDependencyInfoCritical - ] data ServiceAlert = INSTALL | UNINSTALL | RESTORE | START | STOP deriving (Show, Eq, Generic, Hashable, Read) -instance FromJSONKey ServiceAlert -instance ToJSONKey ServiceAlert -instance ToJSON ServiceAlert where - toJSON = String . T.toLower . show -instance FromJSON ServiceAlert where - parseJSON = withText "ServiceAlert" $ \case - "install" -> pure INSTALL - "uninstall" -> pure UNINSTALL - "restore" -> pure RESTORE - "start" -> pure START - "stop" -> pure STOP - _ -> fail "unknown service alert type" data ServiceManifest = ServiceManifest { serviceManifestId :: !PkgId , serviceManifestTitle :: !Text @@ -216,16 +122,6 @@ instance FromJSON ServiceManifest where let serviceManifestAlerts = HM.fromList a serviceManifestDependencies <- o .: "dependencies" pure ServiceManifest { .. } -instance ToJSON ServiceManifest where - toJSON ServiceManifest {..} = object - [ "id" .= serviceManifestId - , "title" .= serviceManifestTitle - , "version" .= serviceManifestVersion - , "description" .= object ["short" .= serviceManifestDescriptionShort, "long" .= serviceManifestDescriptionLong] - , "release-notes" .= serviceManifestReleaseNotes - , "alerts" .= object [ t .= v | (k, v) <- HM.toList serviceManifestAlerts, let (String t) = toJSON k ] - , "dependencies" .= serviceManifestDependencies - ] -- >>> eitherDecode testManifest :: Either String ServiceManifest -- Right (ServiceManifest {serviceManifestId = embassy-pages, serviceManifestTitle = "Embassy Pages", serviceManifestVersion = 0.1.3, serviceManifestDescriptionLong = "Embassy Pages is a simple web server that uses directories inside File Browser to serve Tor websites.", serviceManifestDescriptionShort = "Create Tor websites, hosted on your Embassy.", serviceManifestReleaseNotes = "Upgrade to EmbassyOS v0.3.0", serviceManifestIcon = Just "icon.png", serviceManifestAlerts = fromList [(INSTALL,Nothing),(UNINSTALL,Nothing),(STOP,Nothing),(RESTORE,Nothing),(START,Nothing)], serviceManifestDependencies = fromList [(filebrowser,ServiceDependencyInfo {serviceDependencyInfoOptional = Nothing, serviceDependencyInfoVersion = >=2.14.1.1 <3.0.0, serviceDependencyInfoDescription = Just "Used to upload files to serve.", serviceDependencyInfoCritical = False})]}) diff --git a/src/Lib/Types/FileSystem.hs b/src/Lib/Types/FileSystem.hs deleted file mode 100644 index 229cc39..0000000 --- a/src/Lib/Types/FileSystem.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Lib.Types.FileSystem where - - import Startlude - - data FileExistence = Existent | NonExistent - deriving (Eq, Show) \ No newline at end of file diff --git a/src/Model.hs b/src/Model.hs index 1527183..be11a86 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE QuasiQuotes #-} @@ -6,7 +8,6 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE DataKinds #-} module Model where @@ -18,44 +19,42 @@ import Orphans.Emver ( ) import Startlude share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| -SApp +PkgRecord + Id PkgId sql=pkg_id createdAt UTCTime updatedAt UTCTime Maybe title Text - appId PkgId descShort Text descLong Text iconType Text - UniqueAppId appId deriving Eq deriving Show -SVersion sql=version +VersionRecord sql=version createdAt UTCTime updatedAt UTCTime Maybe - appId SAppId + pkgId PkgRecordId number Version releaseNotes Text - osVersionRequired VersionRange default='*' - osVersionRecommended VersionRange default='*' + osVersion Version arch Text Maybe - UniqueBin appId number + Primary pkgId number deriving Eq deriving Show -OsVersion +OsVersion createdAt UTCTime updatedAt UTCTime number Version headline Text - releaseNotes Text + releaseNotes Text deriving Eq deriving Show Metric createdAt UTCTime - appId SAppId - version SVersionId + pkgId PkgRecordId + version VersionRecordId deriving Eq deriving Show @@ -69,13 +68,10 @@ Category deriving Eq deriving Show -ServiceCategory +PkgCategory createdAt UTCTime - serviceId SAppId + pkgId PkgRecordId categoryId CategoryId - serviceName Text -- SAppAppId - categoryName CategoryTitle -- CategoryTitle - priority Int Maybe deriving Eq deriving Show |] diff --git a/src/Orphans/Yesod.hs b/src/Orphans/Yesod.hs deleted file mode 100644 index 88bc30a..0000000 --- a/src/Orphans/Yesod.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Orphans.Yesod where - -import Startlude - -import Yesod.Core - --- | Forgive me for I have sinned -instance ToJSON a => ToContent [a] where - toContent = toContent . toJSON . fmap toJSON -instance ToJSON a => ToTypedContent [a] where - toTypedContent = toTypedContent . toJSON . fmap toJSON - diff --git a/src/Startlude.hs b/src/Startlude.hs index e8bfd34..ec17f9d 100644 --- a/src/Startlude.hs +++ b/src/Startlude.hs @@ -1,12 +1,10 @@ module Startlude ( module X , module Startlude - ) -where + ) where import Control.Arrow as X ( (&&&) ) --- import Control.Comonad as X import Control.Error.Util as X import Data.Coerce as X import Data.String as X @@ -15,14 +13,14 @@ import Data.String as X ) import Data.Time.Clock as X import Protolude as X - hiding ( bool + hiding ( (<.>) + , bool , hush , isLeft , isRight , note , readMaybe , tryIO - , (<.>) ) import qualified Protolude as P ( readMaybe ) diff --git a/src/Util/Function.hs b/src/Util/Function.hs deleted file mode 100644 index fb20345..0000000 --- a/src/Util/Function.hs +++ /dev/null @@ -1,26 +0,0 @@ -module Util.Function where - -import Startlude - -(.*) :: (b -> c) -> (a0 -> a1 -> b) -> a0 -> a1 -> c -(.*) = (.) . (.) - -(.**) :: (b -> c) -> (a0 -> a1 -> a2 -> b) -> a0 -> a1 -> a2 -> c -(.**) = (.) . (.*) - -preimage :: Eq b => (a -> b) -> b -> [a] -> [a] -preimage f target = filter ((== target) . f) - -mapFind :: ([a] -> Maybe a) -> (b -> a) -> [b] -> Maybe b -mapFind _ _ [] = Nothing -mapFind finder mapping (b : bs) = - let mB = mapFind finder mapping bs - mA = finder [mapping b] - in case (mB, mA) of - (Just b', _ ) -> Just b' - (Nothing, Just _) -> Just b - _ -> Nothing - -(<<&>>) :: (Functor f, Functor g) => f (g a) -> (a -> b) -> f (g b) -f <<&>> fab = fmap (fmap fab) f - diff --git a/src/Util/Shared.hs b/src/Util/Shared.hs index 58b370e..0892f15 100644 --- a/src/Util/Shared.hs +++ b/src/Util/Shared.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleContexts #-} module Util.Shared where diff --git a/test/Handler/MarketplaceSpec.hs b/test/Handler/MarketplaceSpec.hs index 4422caa..2430fcc 100644 --- a/test/Handler/MarketplaceSpec.hs +++ b/test/Handler/MarketplaceSpec.hs @@ -2,18 +2,21 @@ module Handler.MarketplaceSpec ( spec - ) -where + ) where -import Startlude hiding ( Any ) -import Database.Persist.Sql import Data.Maybe +import Database.Persist.Sql +import Startlude hiding ( Any ) -import TestImport -import Model +import Conduit ( (.|) + , runConduit + , sinkList + ) import Database.Marketplace import Lib.Types.Category import Lib.Types.Emver +import Model +import TestImport spec :: Spec spec = do @@ -40,7 +43,7 @@ spec = do _ <- runDBtest $ insert_ $ ServiceCategory time lnd lnCat "lnd" LIGHTNING Nothing _ <- runDBtest $ insert_ $ ServiceCategory time lnd btcCat "lnd" BITCOIN Nothing _ <- runDBtest $ insert_ $ ServiceCategory time btc btcCat "bitcon" BITCOIN Nothing - apps <- runDBtest $ searchServices (Just FEATURED) 20 0 "" + apps <- runDBtest $ runConduit $ searchServices (Just FEATURED) "" .| sinkList assertEq "should exist" (length apps) 1 let app' = fromJust $ head apps assertEq "should be bitcoin" (sAppTitle $ entityVal app') "Bitcoin Core" @@ -67,7 +70,7 @@ spec = do _ <- runDBtest $ insert_ $ ServiceCategory time lnd lnCat "lnd" LIGHTNING Nothing _ <- runDBtest $ insert_ $ ServiceCategory time lnd btcCat "lnd" BITCOIN Nothing _ <- runDBtest $ insert_ $ ServiceCategory time btc btcCat "bitcoind" BITCOIN Nothing - apps <- runDBtest $ searchServices (Just BITCOIN) 20 0 "" + apps <- runDBtest $ runConduit $ searchServices (Just BITCOIN) "" .| sinkList assertEq "should exist" (length apps) 2 describe "searchServices with fuzzy query" $ withApp @@ -91,7 +94,7 @@ spec = do cate <- runDBtest $ insert $ Category time FEATURED Nothing "desc" 0 _ <- runDBtest $ insert_ $ ServiceCategory time app1 cate "bitcoind" FEATURED Nothing _ <- runDBtest $ insert_ $ ServiceCategory time app2 cate "lnd" FEATURED Nothing - apps <- runDBtest $ searchServices (Just FEATURED) 20 0 "lightning" + apps <- runDBtest $ runConduit $ searchServices (Just FEATURED) "lightning" .| sinkList assertEq "should exist" (length apps) 1 let app' = fromJust $ head apps print app' @@ -123,14 +126,5 @@ spec = do _ <- runDBtest $ insert_ $ ServiceCategory time lnd lnCat "lnd" LIGHTNING Nothing _ <- runDBtest $ insert_ $ ServiceCategory time lnd btcCat "lnd" BITCOIN Nothing _ <- runDBtest $ insert_ $ ServiceCategory time btc btcCat "bitcon" BITCOIN Nothing - apps <- runDBtest $ searchServices Nothing 20 0 "" + apps <- runDBtest $ runConduit $ searchServices Nothing "" .| sinkList assertEq "should exist" (length apps) 2 - xdescribe "getServiceVersionsWithReleaseNotes" - $ withApp - $ it "gets service with mapping of version to release notes" - $ do - time <- liftIO getCurrentTime - app <- runDBtest $ insert $ SApp time Nothing "Bitcoin Core" "bitcoin" "short desc" "long desc" "png" - _ <- runDBtest $ insert $ SVersion time Nothing app "0.19.0.0" "release notes 0.19.0.0" Any Any Nothing - _ <- runDBtest $ insert $ SVersion time Nothing app "0.20.0.0" "release notes 0.19.0.0" Any Any Nothing - print ()