From a9d88178cc6370b15b9ca8e709e41bc74dea94a7 Mon Sep 17 00:00:00 2001 From: Lucy Cifferello <12953208+elvece@users.noreply.github.com> Date: Tue, 21 Sep 2021 23:51:45 -0600 Subject: [PATCH 01/48] aggregate query functions --- config/routes | 1 + package.yaml | 9 +- src/Database/Marketplace.hs | 1 - src/Handler/Apps.hs | 10 +- src/Handler/Icons.hs | 4 +- src/Handler/Marketplace.hs | 301 ++++++++++++++++++++++++++++++++++-- src/Lib/Error.hs | 4 + src/Lib/Types/AppIndex.hs | 61 ++++++-- src/Lib/Types/Category.hs | 32 +++- src/Model.hs | 3 +- src/Orphans/Emver.hs | 8 + 11 files changed, 392 insertions(+), 42 deletions(-) diff --git a/config/routes b/config/routes index 827c4a5..dc4abc5 100644 --- a/config/routes +++ b/config/routes @@ -1,6 +1,7 @@ !/package/#S9PK AppR GET -- get most recent appId at appversion spec, defaults to >=0.0.0 -- ?spec={semver-spec} /package/data CategoriesR GET -- get all marketplace categories /package/index PackageListR GET -- filter marketplace services by various query params +-- /package/updates /eos/latest EosR GET -- get eos information /latest-version VersionLatestR GET -- get latest version of apps in query param id /package/manifest/#AppIdentifier AppManifestR GET -- get app manifest from appmgr -- ?version={semver-spec} diff --git a/package.yaml b/package.yaml index d82d6f5..2e574e3 100644 --- a/package.yaml +++ b/package.yaml @@ -16,6 +16,7 @@ dependencies: - base >=4.12 && <5 - aeson - attoparsec +- binary - bytestring - casing - conduit @@ -23,10 +24,12 @@ dependencies: - data-default - directory - errors +- esqueleto - extra - file-embed - fast-logger - filepath +- foreign-store - http-types - interpolate - lens @@ -34,14 +37,17 @@ dependencies: - persistent - persistent-postgresql - persistent-template +- postgresql-simple - process - protolude - shakespeare - template-haskell - text +- text-conversions - time - transformers - typed-process +- unliftio - unordered-containers - unix - wai @@ -53,9 +59,6 @@ dependencies: - yesod - yesod-core - yesod-persistent -- esqueleto -- text-conversions -- foreign-store library: source-dirs: src diff --git a/src/Database/Marketplace.hs b/src/Database/Marketplace.hs index 7bed768..67bedbb 100644 --- a/src/Database/Marketplace.hs +++ b/src/Database/Marketplace.hs @@ -46,7 +46,6 @@ searchServices (Just category) pageItems offset' query = select $ do &&. ( (service ^. SAppDescShort `ilike` (%) ++. val query ++. (%)) ||. (service ^. SAppDescLong `ilike` (%) ++. val query ++. (%)) ||. (service ^. SAppTitle `ilike` (%) ++. val query ++. (%)) - ||. (service ^. SAppAppId `ilike` (%) ++. val query ++. (%)) ) pure service ) diff --git a/src/Handler/Apps.hs b/src/Handler/Apps.hs index 7f8d1ed..bbbc9bb 100644 --- a/src/Handler/Apps.hs +++ b/src/Handler/Apps.hs @@ -77,11 +77,11 @@ getAppManifestR appId = do av <- getVersionFromQuery appsDir appExt >>= \case Nothing -> sendResponseStatus status404 ("Specified App Version Not Found" :: Text) Just v -> pure v - let appDir = (<> "/") . ( show av) . ( toS appId) $ appsDir + let appDir = (<> "/") . ( show av) . ( show appId) $ appsDir manifest <- handleS9ErrT $ getManifest appMgrDir appDir appExt addPackageHeader appMgrDir appDir appExt pure $ TypedContent "application/json" (toContent manifest) - where appExt = Extension (toS appId) :: Extension "s9pk" + where appExt = Extension (show appId) :: Extension "s9pk" getAppConfigR :: AppIdentifier -> Handler TypedContent getAppConfigR appId = do @@ -91,11 +91,11 @@ getAppConfigR appId = do av <- getVersionFromQuery appsDir appExt >>= \case Nothing -> sendResponseStatus status404 ("Specified App Version Not Found" :: Text) Just v -> pure v - let appDir = (<> "/") . ( show av) . ( toS appId) $ appsDir + let appDir = (<> "/") . ( show av) . ( show appId) $ appsDir config <- handleS9ErrT $ getConfig appMgrDir appDir appExt addPackageHeader appMgrDir appDir appExt pure $ TypedContent "application/json" (toContent config) - where appExt = Extension (toS appId) :: Extension "s9pk" + where appExt = Extension (show appId) :: Extension "s9pk" getAppR :: Extension "s9pk" -> Handler TypedContent getAppR e = do @@ -142,7 +142,7 @@ chunkIt fp = do recordMetrics :: String -> Version -> HandlerFor RegistryCtx () recordMetrics appId appVersion = do let appId' = T.pack appId - sa <- runDB $ fetchApp appId' + sa <- runDB $ fetchApp $ AppIdentifier appId' case sa of Nothing -> do $logError $ appId' <> " not found in database" diff --git a/src/Handler/Icons.hs b/src/Handler/Icons.hs index 7dadaba..87c6925 100644 --- a/src/Handler/Icons.hs +++ b/src/Handler/Icons.hs @@ -78,7 +78,7 @@ getLicenseR appId = do Nothing -> notFound Just p -> do respondSource typePlain (sendChunkBS =<< handleS9ErrT (getLicense appMgrDir p ext)) - where ext = Extension (toS appId) :: Extension "s9pk" + where ext = Extension (show appId) :: Extension "s9pk" getInstructionsR :: AppIdentifier -> Handler TypedContent getInstructionsR appId = do @@ -91,4 +91,4 @@ getInstructionsR appId = do Nothing -> notFound Just p -> do respondSource typePlain (sendChunkBS =<< handleS9ErrT (getInstructions appMgrDir p ext)) - where ext = Extension (toS appId) :: Extension "s9pk" + where ext = Extension (show appId) :: Extension "s9pk" diff --git a/src/Handler/Marketplace.hs b/src/Handler/Marketplace.hs index 46f0968..5b022c9 100644 --- a/src/Handler/Marketplace.hs +++ b/src/Handler/Marketplace.hs @@ -7,9 +7,11 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TupleSections #-} - +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveAnyClass #-} module Handler.Marketplace where +<<<<<<< HEAD import Startlude hiding ( from , Handler , on @@ -39,6 +41,40 @@ import qualified Data.ByteString.Lazy as BS import qualified Data.Text as T import Data.String.Interpolate.IsString import Util.Shared +======= +import Startlude hiding (from, Handler, on, sortOn) +import Foundation +import Yesod.Core +import qualified Database.Persist as P +import Model +import Yesod.Persist.Core +import Database.Marketplace +import Data.List +import Lib.Types.Category +import Lib.Types.AppIndex +import qualified Data.HashMap.Strict as HM +import Lib.Types.Emver +import qualified Data.List.NonEmpty as NE +import Database.Esqueleto.Experimental +import Lib.Error +import Network.HTTP.Types +import Lib.Registry +import Settings +import System.FilePath.Posix +import Lib.External.AppMgr +import Data.Aeson +import qualified Data.ByteString.Lazy as BS +import qualified Data.Text as T +import Data.String.Interpolate.IsString +import Util.Shared +import Lib.Types.AppIndex() +import UnliftIO.Async +import qualified Database.PostgreSQL.Simple as PS +import qualified Database.Persist.Postgresql as PP +import Database.PostgreSQL.Simple (FromRow) +import Database.PostgreSQL.Simple.FromRow (FromRow(fromRow), field) +import Database.Esqueleto.PostgreSQL (arrayAggDistinct) +>>>>>>> aggregate query functions newtype CategoryRes = CategoryRes { categories :: [CategoryTitle] @@ -82,8 +118,8 @@ instance ToContent ServiceRes where instance ToTypedContent ServiceRes where toTypedContent = toTypedContent . toJSON data DependencyInfo = DependencyInfo - { dependencyInfoTitle :: Text -- title - , dependencyInfoIcon :: Text -- url + { dependencyInfoTitle :: AppIdentifier + , dependencyInfoIcon :: URL } deriving (Eq, Show) instance ToJSON DependencyInfo where toJSON DependencyInfo {..} = object ["icon" .= dependencyInfoIcon, "title" .= dependencyInfoTitle] @@ -101,7 +137,7 @@ instance ToTypedContent ServiceListRes where toTypedContent = toTypedContent . toJSON data ServiceAvailable = ServiceAvailable - { serviceAvailableId :: Text + { serviceAvailableId :: AppIdentifier , serviceAvailableTitle :: Text , serviceAvailableVersion :: Version , serviceAvailableIcon :: URL @@ -151,8 +187,16 @@ data EosRes = EosRes , eosResReleaseNotes :: ReleaseNotes } deriving (Eq, Show, Generic) instance ToJSON EosRes where +<<<<<<< HEAD toJSON EosRes {..} = object ["version" .= eosResVersion, "headline" .= eosResHeadline, "release-notes" .= eosResReleaseNotes] +======= + toJSON EosRes { .. } = object + [ "version" .= eosResVersion + , "headline" .= eosResHeadline + , "release-notes" .= eosResReleaseNotes + ] +>>>>>>> aggregate query functions instance ToContent EosRes where toContent = toContent . toJSON instance ToTypedContent EosRes where @@ -201,8 +245,13 @@ getReleaseNotesR = do case lookup "id" getParameters of Nothing -> sendResponseStatus status400 ("expected query param \"id\" to exist" :: Text) Just package -> do +<<<<<<< HEAD (service, _ ) <- runDB $ fetchLatestApp package >>= errOnNothing status404 "package not found" (_ , mappedVersions) <- fetchAllAppVersions (entityKey service) +======= + (service, _) <- runDB $ fetchLatestApp (AppIdentifier package) >>= errOnNothing status404 "package not found" + (_, mappedVersions) <- fetchAllAppVersions (entityKey service) +>>>>>>> aggregate query functions pure mappedVersions getVersionLatestR :: Handler VersionLatestRes @@ -211,6 +260,7 @@ getVersionLatestR = do case lookup "ids" getParameters of Nothing -> sendResponseStatus status400 ("expected query param \"ids\" to exist" :: Text) Just packages -> case eitherDecode $ BS.fromStrict $ encodeUtf8 packages of +<<<<<<< HEAD Left e -> sendResponseStatus status400 ("could not parse query param \"ids\"" <> show e :: Text) Right (p :: [AppIdentifier]) -> do let packageList :: [(AppIdentifier, Maybe Version)] = (, Nothing) <$> p @@ -227,16 +277,33 @@ getVersionLatestR = do <$> catMaybes found ) $ HM.fromList packageList +======= + Left e -> sendResponseStatus status400 ("could not parse query param \"ids\"" <> show e :: Text) + Right (p :: [AppIdentifier])-> do + let packageList :: [(AppIdentifier, Maybe Version)] = (, Nothing) <$> p + found <- runDB $ traverse fetchLatestApp $ fst <$> packageList + pure $ VersionLatestRes $ HM.union (HM.fromList $ (\v -> (sAppAppId $ entityVal $ fst v, Just $ sVersionNumber $ entityVal $ snd v)) <$> catMaybes found) $ HM.fromList packageList +>>>>>>> aggregate query functions getPackageListR :: Handler ServiceAvailableRes getPackageListR = do getParameters <- reqGetParams <$> getRequest +<<<<<<< HEAD let defaults = ServiceListDefaults { serviceListOrder = DESC , serviceListPageLimit = 20 , serviceListPageNumber = 1 , serviceListCategory = Nothing , serviceListQuery = "" } +======= + let defaults = ServiceListDefaults + { serviceListOrder = DESC + , serviceListPageLimit = 20 + , serviceListPageNumber = 1 + , serviceListCategory = Nothing + , serviceListQuery = "" + } +>>>>>>> aggregate query functions case lookup "ids" getParameters of Nothing -> do -- query for all @@ -263,13 +330,19 @@ getPackageListR = do Just l -> pure l query <- T.filter (not . isSpace) . fromMaybe (serviceListQuery defaults) <$> lookupGetParam "query" filteredServices <- runDB $ searchServices category limit' ((page - 1) * limit') query - -- domain <- getsYesod $ registryHostname . appSettings - -- (appsDir, appMgrDir) <- getsYesod $ (( "apps") . resourcesDir &&& staticBinDir) . appSettings - -- res <- runDB $ traverse (mapEntityToServiceAvailable appMgrDir appsDir domain) filteredServices - res <- traverse (getServiceDetails Nothing) filteredServices - pure $ ServiceAvailableRes res + let filteredServices' = sAppAppId . entityVal <$> filteredServices + settings <- getsYesod appSettings + packageMetadata <- runDB $ fetchPackageMetadata filteredServices' + $logInfo $ show packageMetadata + serviceDetailResult <- liftIO $ mapConcurrently (getServiceDetails settings packageMetadata Nothing) filteredServices' + let (errors, services) = partitionEithers serviceDetailResult + pure $ ServiceAvailableRes services + -- if null errors + -- then pure $ ServiceAvailableRes services + -- else sendResponseStatus status500 ("Errors acquiring service details: " <> show <$> errors) Just packageVersionList -> case eitherDecode $ BS.fromStrict $ encodeUtf8 packageVersionList of +<<<<<<< HEAD Left e -> sendResponseStatus status400 ("could not parse query param \"ids\"" <> show e :: Text) Right (packages :: [PackageVersion]) -> do -- for each item in list get best available from version range @@ -347,10 +420,70 @@ mapDependencyMetadata :: (MonadIO m, MonadHandler m) -> Text -> (AppIdentifier, ServiceDependencyInfo) -> m (AppIdentifier, DependencyInfo) +======= + Left e -> sendResponseStatus status400 ("could not parse query param \"ids\"" <> show e :: Text) + Right (packages :: [PackageVersion])-> do + -- for each item in list get best available from version range + settings <- getsYesod appSettings + availableServices <- traverse (getPackageDetails settings) packages + packageMetadata <- runDB $ fetchPackageMetadata (snd <$> availableServices) + serviceDetailResult <- liftIO $ mapConcurrently (uncurry $ getServiceDetails settings packageMetadata) availableServices + let (errors, services) = partitionEithers serviceDetailResult + pure $ ServiceAvailableRes services + -- if null errors + -- then pure $ ServiceAvailableRes services + -- else sendResponseStatus status500 ("Errors acquiring service details: " <> show <$> errors) + where + getPackageDetails :: (MonadHandler m) => AppSettings -> PackageVersion -> m (Maybe Version, AppIdentifier) + getPackageDetails settings pv = do + let appId = packageVersionId pv + let spec = packageVersionVersion pv + let appExt = Extension (show appId) :: Extension "s9pk" + getBestVersion (( "apps") . resourcesDir $ settings) appExt spec >>= \case + Nothing -> sendResponseStatus status404 ("best version could not be found for " <> show appId <> " with spec " <> show spec :: Text) + Just v -> do + pure (Just v, appId) + +getServiceDetails :: (MonadIO m, Monad m, MonadError IOException m) => AppSettings -> (HM.HashMap AppIdentifier ([Version], [CategoryTitle])) -> Maybe Version -> AppIdentifier -> m (Either Text ServiceRes) +getServiceDetails settings metadata maybeVersion appId = do + packageMetadata <- case HM.lookup appId metadata of + Nothing-> throwIO $ NotFoundE [i|#{appId} not found.|] + Just m -> pure m + let (appsDir, appMgrDir) = (( "apps") . resourcesDir &&& staticBinDir) settings + let domain = registryHostname settings + version <- case maybeVersion of + Nothing -> do + -- grab first value, which will be the latest version + case fst packageMetadata of + [] -> throwIO $ NotFoundE $ "no latest version found for " <> show appId + x:_ -> pure x + Just v -> pure v + let appDir = (<> "/") . ( show version) . ( show appId) $ appsDir + let appExt = Extension (show appId) :: Extension "s9pk" + manifest' <- handleS9ErrNuclear $ getManifest appMgrDir appDir appExt + case eitherDecode $ BS.fromStrict manifest' of + Left e -> pure $ Left $ "Could not parse service manifest for " <> show appId <> ": " <> show e + Right m -> do + d <- liftIO $ mapConcurrently (mapDependencyMetadata appsDir domain) (HM.toList $ serviceManifestDependencies m) + pure $ Right $ ServiceRes + { serviceResIcon = [i|https://#{domain}/package/icon/#{appId}|] + , serviceResManifest = decode $ BS.fromStrict manifest' -- pass through raw JSON Value + , serviceResCategories = snd packageMetadata + , serviceResInstructions = [i|https://#{domain}/package/instructions/#{appId}|] + , serviceResLicense = [i|https://#{domain}/package/license/#{appId}|] + , serviceResVersions = fst packageMetadata + , serviceResDependencyInfo = HM.fromList $ snd $ partitionEithers d + } + + +type URL = Text +mapDependencyMetadata :: (MonadIO m) => FilePath -> Text -> (AppIdentifier, ServiceDependencyInfo) -> m (Either Text (AppIdentifier, DependencyInfo)) +>>>>>>> aggregate query functions mapDependencyMetadata appsDir domain (appId, depInfo) = do - let ext = (Extension (toS appId) :: Extension "s9pk") + let ext = (Extension (show appId) :: Extension "s9pk") -- get best version from VersionRange of dependency version <- getBestVersion appsDir ext (serviceDependencyInfoVersion depInfo) >>= \case +<<<<<<< HEAD Nothing -> sendResponseStatus status404 ("best version not found for dependent package " <> appId :: Text) Just v -> pure v pure @@ -359,6 +492,14 @@ mapDependencyMetadata appsDir domain (appId, depInfo) = do , dependencyInfoIcon = [i|https://#{domain}/package/icon/#{appId}?spec==#{version}|] } ) +======= + Nothing -> throwIO $ NotFoundE $ "best version not found for dependent package " <> show appId + Just v -> pure v + pure $ Right (appId, DependencyInfo + { dependencyInfoTitle = appId + , dependencyInfoIcon = [i|https://#{domain}/package/icon/#{appId}?spec==#{version}|] + }) +>>>>>>> aggregate query functions decodeIcon :: (MonadHandler m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> m URL decodeIcon appmgrPath depPath e@(Extension icon) = do @@ -386,6 +527,17 @@ fetchAllAppVersions appId = do let vv = mapSVersionToVersionInfo vers let mappedVersions = ReleaseNotes $ HM.fromList $ (\v -> (versionInfoVersion v, versionInfoReleaseNotes v)) <$> vv pure (vv, mappedVersions) + where + mapSVersionToVersionInfo :: [SVersion] -> [VersionInfo] + mapSVersionToVersionInfo sv = do + (\v -> VersionInfo { + versionInfoVersion = sVersionNumber v + , versionInfoReleaseNotes = sVersionReleaseNotes v + , versionInfoDependencies = HM.empty + , versionInfoOsRequired = sVersionOsVersionRequired v + , versionInfoOsRecommended = sVersionOsVersionRecommended v + , versionInfoInstallAlert = Nothing + }) <$> sv fetchMostRecentAppVersions :: MonadIO m => Key SApp -> ReaderT SqlBackend m [Entity SVersion] fetchMostRecentAppVersions appId = select $ do @@ -395,8 +547,9 @@ fetchMostRecentAppVersions appId = select $ do limit 1 pure version -fetchLatestApp :: MonadIO m => Text -> ReaderT SqlBackend m (Maybe (P.Entity SApp, P.Entity SVersion)) +fetchLatestApp :: MonadIO m => AppIdentifier -> ReaderT SqlBackend m (Maybe (P.Entity SApp, P.Entity SVersion)) fetchLatestApp appId = selectOne $ do +<<<<<<< HEAD (service :& version) <- from $ table @SApp @@ -410,6 +563,18 @@ fetchLatestAppAtVersion :: MonadIO m => Text -> Version -> ReaderT SqlBackend m (Maybe (P.Entity SApp, P.Entity SVersion)) +======= + (service :& version) <- + from $ table @SApp + `innerJoin` table @SVersion + `on` (\(service :& version) -> + service ^. SAppId ==. version ^. SVersionAppId) + where_ (service ^. SAppAppId ==. val appId) + orderBy [ desc (version ^. SVersionNumber)] + pure (service, version) + +fetchLatestAppAtVersion :: MonadIO m => AppIdentifier -> Version -> ReaderT SqlBackend m (Maybe (P.Entity SApp, P.Entity SVersion)) +>>>>>>> aggregate query functions fetchLatestAppAtVersion appId version' = selectOne $ do (service :& version) <- from @@ -419,6 +584,92 @@ fetchLatestAppAtVersion appId version' = selectOne $ do where_ $ (service ^. SAppAppId ==. val appId) &&. (version ^. SVersionNumber ==. val version') pure (service, version) +data PackageMetadata = PackageMetadata + { packageMetadataId :: AppIdentifier + , packageMetadataVersions :: [Version] + , packageMetadataCategories :: [CategoryTitle] + } deriving (Eq, Show, Generic) +instance RawSql PackageMetadata where + rawSqlCols _ _ = (3, []) + rawSqlColCountReason _ = "because that is the number of fields in the data type" + rawSqlProcessRow pv = case pv of + [] -> Left "empty row" + _:xs -> Right $ PackageMetadata + { packageMetadataId = case fromPersistValue $ xs !! 1 of + Left _ -> "" + Right v -> v + , packageMetadataVersions = case fromPersistValue $ xs !! 2 of + Left _ -> [] + Right v -> v + , packageMetadataCategories = case fromPersistValue $ xs !! 3 of + Left _ -> [] + Right v -> v + } +-- instance FromJSON PackageMetadata where +-- parseJSON = withObject "package data" $ \o -> do +-- packageMetadataId <- o .: "app_id" +-- packageMetadataVersions <- o .: "versions" +-- packageMetadataCategories <- o .: "categories" +-- pure PackageMetadata { .. } +-- instance ToJSON PackageMetadata where +-- toJSON PackageMetadata {..} = object +-- [ "app_id" .= packageMetadataId +-- , "versions" .= packageMetadataVersions +-- , "categories" .= packageMetadataCategories +-- ] +-- instance PersistField PackageMetadata where +-- fromPersistValue = fromPersistValueJSON +-- toPersistValue = toPersistValueJSON +-- instance FromRow PackageMetadata where +-- fromRow = PackageMetadata <$> field <*> (fmap Version <$> field) <*> (fmap parseCT <$> field) + +fetchPackageMetadataX :: MonadIO m => [AppIdentifier] -> ReaderT SqlBackend m [PackageMetadata] +fetchPackageMetadataX ids = rawSql "SELECT s.app_id, json_agg(DISTINCT v.number ORDER BY v.number DESC) AS versions, json_agg(DISTINCT c.category_name) AS categories FROM s_app s LEFT JOIN service_category c on s.id = c.service_id JOIN version v on v.app_id = s.id WHERE s.app_id IN (?) GROUP BY s.app_id" [PersistList (toPersistValue <$> ids)] + +fetchPackageMetadata :: MonadUnliftIO m => [AppIdentifier] -> ReaderT SqlBackend m (HM.HashMap AppIdentifier ([Version], [CategoryTitle])) +fetchPackageMetadata ids = do + let categoriesQuery = select $ do + (service :& category) <- from $ table @SApp + `leftJoin` table @ServiceCategory + `on` (\(service :& category) -> Database.Esqueleto.Experimental.just (service ^. SAppId) ==. category ?. ServiceCategoryServiceId) + where_ $ + service ^. SAppAppId `in_` valList ids + 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) + where_ $ + service ^. SAppAppId `in_` valList ids + orderBy [ desc (version ^. SVersionNumber) ] + 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')) + pure $ HM.intersectionWith (\ vers cts -> (vers, cts)) (HM.fromList v) (HM.fromList c) + +-- fetchPackageMetadata :: MonadIO m => [AppIdentifier] -> ReaderT SqlBackend m [PackageMetadata] +fetchPackageMetadata_ :: (MonadLogger m, MonadIO m) => [AppIdentifier] -> AppSettings -> m [PackageMetadata] +fetchPackageMetadata_ ids settings = do + let connString = PP.pgConnStr $ appDatabaseConf settings + conn <- liftIO $ PS.connectPostgreSQL connString + res <- liftIO $ PS.query conn query $ PS.Only $ PS.In ids + $logInfo $ show query + $logInfo$ show res + $logInfo$ show ids + forM res $ \(appId, versions, categories) -> + pure $ PackageMetadata + { packageMetadataId = appId + , packageMetadataVersions = versions + , packageMetadataCategories = categories + } + where + query :: PS.Query + query = "SELECT s.app_id, json_agg(DISTINCT v.number ORDER BY v.number DESC) AS versions, json_agg(DISTINCT c.category_name) AS categories FROM s_app s LEFT JOIN service_category c on s.id = c.service_id JOIN version v on v.app_id = s.id WHERE s.app_id IN ? GROUP BY s.app_id" + -- query = "SELECT \"s_app\".\"app_id\", json_agg(DISTINCT \"version\".\"number\" ORDER BY \"version\".\"number\" DESC) AS \"versions\", json_agg(DISTINCT \"service_category\".\"category_name\") AS \"categories\" FROM \"s_app\" LEFT JOIN \"service_category\" on \"s_app\".\"id\" = \"service_category\".\"service_id\" JOIN \"version\" on \"version\".\"app_id\" = \"s_app\".\"id\" WHERE \"s_app\".\"app_id\" IN ? GROUP BY \"s_app\".\"app_id\"" + fetchAppCategories :: MonadIO m => Key SApp -> ReaderT SqlBackend m [P.Entity ServiceCategory] fetchAppCategories appId = select $ do (categories :& service) <- @@ -431,6 +682,7 @@ fetchAppCategories appId = select $ do mapEntityToStoreApp :: MonadIO m => Entity SApp -> ReaderT SqlBackend m StoreApp mapEntityToStoreApp serviceEntity = do +<<<<<<< HEAD let service = entityVal serviceEntity entityVersion <- fetchMostRecentAppVersions $ entityKey serviceEntity let vers = entityVal <$> entityVersion @@ -447,6 +699,33 @@ mapEntityToServiceAvailable :: (MonadIO m, MonadHandler m) => Text -> Entity SApp -> ReaderT SqlBackend m ServiceAvailable +======= + let service = entityVal serviceEntity + entityVersion <- fetchMostRecentAppVersions $ entityKey serviceEntity + let vers = entityVal <$> entityVersion + let vv = mapSVersionToVersionInfo vers + pure $ StoreApp { + storeAppTitle = sAppTitle service + , storeAppDescShort = sAppDescShort service + , storeAppDescLong = sAppDescLong service + , storeAppVersionInfo = NE.fromList vv + , storeAppIconType = sAppIconType service + , storeAppTimestamp = Just (sAppCreatedAt service) -- case on if updatedAt? or always use updated time? was file timestamp + } + where + mapSVersionToVersionInfo :: [SVersion] -> [VersionInfo] + mapSVersionToVersionInfo sv = do + (\v -> VersionInfo { + versionInfoVersion = sVersionNumber v + , versionInfoReleaseNotes = sVersionReleaseNotes v + , versionInfoDependencies = HM.empty + , versionInfoOsRequired = sVersionOsVersionRequired v + , versionInfoOsRecommended = sVersionOsVersionRecommended v + , versionInfoInstallAlert = Nothing + }) <$> sv + +mapEntityToServiceAvailable :: (MonadIO m, MonadHandler m) => Text -> Entity SApp -> ReaderT SqlBackend m ServiceAvailable +>>>>>>> aggregate query functions mapEntityToServiceAvailable domain service = do let appId = sAppAppId $ entityVal service (_, v) <- fetchLatestApp appId >>= errOnNothing status404 "service not found" diff --git a/src/Lib/Error.hs b/src/Lib/Error.hs index aa67125..e9a01e7 100644 --- a/src/Lib/Error.hs +++ b/src/Lib/Error.hs @@ -14,6 +14,7 @@ type S9ErrT m = ExceptT S9Error m data S9Error = PersistentE Text | AppMgrE Text Int + | NotFoundE Text deriving (Show, Eq) instance Exception S9Error @@ -23,10 +24,12 @@ toError :: S9Error -> Error toError = \case PersistentE t -> Error DATABASE_ERROR t AppMgrE cmd code -> Error APPMGR_ERROR [i|"appmgr #{cmd}" exited with #{code}|] + NotFoundE e -> Error NOT_FOUND [i|#{e}|] data ErrorCode = DATABASE_ERROR | APPMGR_ERROR + | NOT_FOUND deriving (Eq, Show) instance ToJSON ErrorCode where @@ -53,6 +56,7 @@ toStatus :: S9Error -> Status toStatus = \case PersistentE _ -> status500 AppMgrE _ _ -> status500 + NotFoundE _ -> status404 handleS9ErrT :: MonadHandler m => S9ErrT m a -> m a diff --git a/src/Lib/Types/AppIndex.hs b/src/Lib/Types/AppIndex.hs index da8bc99..17d45c6 100644 --- a/src/Lib/Types/AppIndex.hs +++ b/src/Lib/Types/AppIndex.hs @@ -18,12 +18,57 @@ import Lib.Types.Emver import Orphans.Emver ( ) import System.Directory import Lib.Registry -import Model +-- import Model import qualified Data.Text as T import Data.String.Interpolate.IsString import qualified Data.ByteString.Lazy as BS +import Database.Persist.Postgresql +import Yesod +import Data.Functor.Contravariant ( Contravariant(contramap) ) +import qualified GHC.Read ( Read(..) ) +import qualified GHC.Show ( Show(..) ) +import Database.PostgreSQL.Simple.ToField +import Database.PostgreSQL.Simple.FromField +import Data.Binary.Builder -type AppIdentifier = Text +newtype AppIdentifier = AppIdentifier { unAppIdentifier :: Text } + deriving (Eq) +instance IsString AppIdentifier where + fromString = AppIdentifier . fromString +instance Show AppIdentifier where + show = toS . unAppIdentifier +instance Read AppIdentifier where + readsPrec _ s = [(AppIdentifier $ toS s, "")] +instance Hashable AppIdentifier where + hashWithSalt n = hashWithSalt n . unAppIdentifier +instance FromJSON AppIdentifier where + parseJSON = fmap AppIdentifier . parseJSON +instance ToJSON AppIdentifier where + toJSON = toJSON . unAppIdentifier +instance FromJSONKey AppIdentifier where + fromJSONKey = fmap AppIdentifier fromJSONKey +instance ToJSONKey AppIdentifier where + toJSONKey = contramap unAppIdentifier toJSONKey +instance PersistField AppIdentifier where + toPersistValue = PersistText . show + fromPersistValue (PersistText t) = Right . AppIdentifier $ toS t + fromPersistValue other = Left $ "Invalid AppId: " <> show other +instance PersistFieldSql AppIdentifier where + sqlType _ = SqlString +instance PathPiece AppIdentifier where + fromPathPiece = fmap AppIdentifier . fromPathPiece + toPathPiece = unAppIdentifier +instance ToContent AppIdentifier where + toContent = toContent . toJSON +instance ToTypedContent AppIdentifier where + toTypedContent = toTypedContent . toJSON +instance ToField AppIdentifier where + toField a = toJSONField a + -- Escape $ BS.toStrict $ encode a + -- Plain $ inQuotes $ putStringUtf8 $ show a + -- $ fromByteString $ BS.toStrict $ encode a +instance FromField AppIdentifier where + fromField = fromJSONField data VersionInfo = VersionInfo { versionInfoVersion :: Version @@ -35,18 +80,6 @@ data VersionInfo = VersionInfo } deriving (Eq, Show) -mapSVersionToVersionInfo :: [SVersion] -> [VersionInfo] -mapSVersionToVersionInfo sv = do - (\v -> VersionInfo { versionInfoVersion = sVersionNumber v - , versionInfoReleaseNotes = sVersionReleaseNotes v - , versionInfoDependencies = HM.empty - , versionInfoOsRequired = sVersionOsVersionRequired v - , versionInfoOsRecommended = sVersionOsVersionRecommended v - , versionInfoInstallAlert = Nothing - } - ) - <$> sv - instance Ord VersionInfo where compare = compare `on` versionInfoVersion diff --git a/src/Lib/Types/Category.hs b/src/Lib/Types/Category.hs index d302ae9..80ee041 100644 --- a/src/Lib/Types/Category.hs +++ b/src/Lib/Types/Category.hs @@ -3,11 +3,13 @@ module Lib.Types.Category where -import Startlude -import Database.Persist.Postgresql -import Data.Aeson -import Control.Monad -import Yesod.Core +import Startlude +import Database.Persist.Postgresql +import Data.Aeson +import Control.Monad +import Yesod.Core +import Database.PostgreSQL.Simple.FromField +import Database.PostgreSQL.Simple.ToField data CategoryTitle = FEATURED | BITCOIN @@ -46,3 +48,23 @@ instance ToContent CategoryTitle where toContent = toContent . toJSON instance ToTypedContent CategoryTitle where toTypedContent = toTypedContent . toJSON +<<<<<<< HEAD +======= +instance FromField CategoryTitle where + fromField a = fromJSONField a +instance FromField [CategoryTitle] where + fromField a = fromJSONField a +instance ToField [CategoryTitle] where + toField a = toJSONField a + +parseCT :: Text -> CategoryTitle +parseCT = \case + "featured" -> FEATURED + "bitcoin" -> BITCOIN + "lightning" -> LIGHTNING + "data" -> DATA + "messaging" -> MESSAGING + "social" -> SOCIAL + "alt coin" -> ALTCOIN + -- _ -> fail "unknown category title" +>>>>>>> aggregate query functions diff --git a/src/Model.hs b/src/Model.hs index 30373de..11de26f 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -15,13 +15,14 @@ import Database.Persist.TH import Lib.Types.Emver import Lib.Types.Category import Orphans.Emver ( ) +import Lib.Types.AppIndex share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| SApp createdAt UTCTime updatedAt UTCTime Maybe title Text - appId Text + appId AppIdentifier descShort Text descLong Text iconType Text diff --git a/src/Orphans/Emver.hs b/src/Orphans/Emver.hs index 24976a3..502595f 100644 --- a/src/Orphans/Emver.hs +++ b/src/Orphans/Emver.hs @@ -13,6 +13,8 @@ import Lib.Types.Emver import Database.Persist.Sql import qualified Data.Text as T import Control.Monad.Fail ( MonadFail(fail) ) +import Database.PostgreSQL.Simple.FromField +import Database.PostgreSQL.Simple.ToField instance FromJSON Version where parseJSON = withText "Emver Version" $ either fail pure . Atto.parseOnly parseVersion @@ -33,3 +35,9 @@ instance PersistField VersionRange where fromPersistValue = first T.pack . Atto.parseOnly parseRange <=< fromPersistValue instance PersistFieldSql VersionRange where sqlType _ = SqlString +instance FromField Version where + fromField a = fromJSONField a +instance FromField [Version] where + fromField a = fromJSONField a +instance ToField [Version] where + toField a = toJSONField a \ No newline at end of file From d535d16a894064a1ec1ff028907245e950405213 Mon Sep 17 00:00:00 2001 From: Lucy Cifferello <12953208+elvece@users.noreply.github.com> Date: Tue, 21 Sep 2021 23:58:34 -0600 Subject: [PATCH 02/48] clean up --- src/Handler/Marketplace.hs | 421 +++++++++---------------------------- src/Lib/External/AppMgr.hs | 6 +- src/Lib/Types/AppIndex.hs | 10 - src/Lib/Types/Category.hs | 6 +- 4 files changed, 111 insertions(+), 332 deletions(-) diff --git a/src/Handler/Marketplace.hs b/src/Handler/Marketplace.hs index 5b022c9..6db53a1 100644 --- a/src/Handler/Marketplace.hs +++ b/src/Handler/Marketplace.hs @@ -11,7 +11,6 @@ {-# LANGUAGE DeriveAnyClass #-} module Handler.Marketplace where -<<<<<<< HEAD import Startlude hiding ( from , Handler , on @@ -41,40 +40,9 @@ import qualified Data.ByteString.Lazy as BS import qualified Data.Text as T import Data.String.Interpolate.IsString import Util.Shared -======= -import Startlude hiding (from, Handler, on, sortOn) -import Foundation -import Yesod.Core -import qualified Database.Persist as P -import Model -import Yesod.Persist.Core -import Database.Marketplace -import Data.List -import Lib.Types.Category -import Lib.Types.AppIndex -import qualified Data.HashMap.Strict as HM -import Lib.Types.Emver -import qualified Data.List.NonEmpty as NE -import Database.Esqueleto.Experimental -import Lib.Error -import Network.HTTP.Types -import Lib.Registry -import Settings -import System.FilePath.Posix -import Lib.External.AppMgr -import Data.Aeson -import qualified Data.ByteString.Lazy as BS -import qualified Data.Text as T -import Data.String.Interpolate.IsString -import Util.Shared -import Lib.Types.AppIndex() -import UnliftIO.Async -import qualified Database.PostgreSQL.Simple as PS -import qualified Database.Persist.Postgresql as PP -import Database.PostgreSQL.Simple (FromRow) -import Database.PostgreSQL.Simple.FromRow (FromRow(fromRow), field) -import Database.Esqueleto.PostgreSQL (arrayAggDistinct) ->>>>>>> aggregate query functions +import Lib.Types.AppIndex ( ) +import UnliftIO.Async +import Database.Esqueleto.PostgreSQL ( arrayAggDistinct ) newtype CategoryRes = CategoryRes { categories :: [CategoryTitle] @@ -187,16 +155,8 @@ data EosRes = EosRes , eosResReleaseNotes :: ReleaseNotes } deriving (Eq, Show, Generic) instance ToJSON EosRes where -<<<<<<< HEAD toJSON EosRes {..} = object ["version" .= eosResVersion, "headline" .= eosResHeadline, "release-notes" .= eosResReleaseNotes] -======= - toJSON EosRes { .. } = object - [ "version" .= eosResVersion - , "headline" .= eosResHeadline - , "release-notes" .= eosResReleaseNotes - ] ->>>>>>> aggregate query functions instance ToContent EosRes where toContent = toContent . toJSON instance ToTypedContent EosRes where @@ -245,13 +205,8 @@ getReleaseNotesR = do case lookup "id" getParameters of Nothing -> sendResponseStatus status400 ("expected query param \"id\" to exist" :: Text) Just package -> do -<<<<<<< HEAD (service, _ ) <- runDB $ fetchLatestApp package >>= errOnNothing status404 "package not found" (_ , mappedVersions) <- fetchAllAppVersions (entityKey service) -======= - (service, _) <- runDB $ fetchLatestApp (AppIdentifier package) >>= errOnNothing status404 "package not found" - (_, mappedVersions) <- fetchAllAppVersions (entityKey service) ->>>>>>> aggregate query functions pure mappedVersions getVersionLatestR :: Handler VersionLatestRes @@ -260,7 +215,6 @@ getVersionLatestR = do case lookup "ids" getParameters of Nothing -> sendResponseStatus status400 ("expected query param \"ids\" to exist" :: Text) Just packages -> case eitherDecode $ BS.fromStrict $ encodeUtf8 packages of -<<<<<<< HEAD Left e -> sendResponseStatus status400 ("could not parse query param \"ids\"" <> show e :: Text) Right (p :: [AppIdentifier]) -> do let packageList :: [(AppIdentifier, Maybe Version)] = (, Nothing) <$> p @@ -277,33 +231,16 @@ getVersionLatestR = do <$> catMaybes found ) $ HM.fromList packageList -======= - Left e -> sendResponseStatus status400 ("could not parse query param \"ids\"" <> show e :: Text) - Right (p :: [AppIdentifier])-> do - let packageList :: [(AppIdentifier, Maybe Version)] = (, Nothing) <$> p - found <- runDB $ traverse fetchLatestApp $ fst <$> packageList - pure $ VersionLatestRes $ HM.union (HM.fromList $ (\v -> (sAppAppId $ entityVal $ fst v, Just $ sVersionNumber $ entityVal $ snd v)) <$> catMaybes found) $ HM.fromList packageList ->>>>>>> aggregate query functions getPackageListR :: Handler ServiceAvailableRes getPackageListR = do getParameters <- reqGetParams <$> getRequest -<<<<<<< HEAD let defaults = ServiceListDefaults { serviceListOrder = DESC , serviceListPageLimit = 20 , serviceListPageNumber = 1 , serviceListCategory = Nothing , serviceListQuery = "" } -======= - let defaults = ServiceListDefaults - { serviceListOrder = DESC - , serviceListPageLimit = 20 - , serviceListPageNumber = 1 - , serviceListCategory = Nothing - , serviceListQuery = "" - } ->>>>>>> aggregate query functions case lookup "ids" getParameters of Nothing -> do -- query for all @@ -331,175 +268,105 @@ getPackageListR = do query <- T.filter (not . isSpace) . fromMaybe (serviceListQuery defaults) <$> lookupGetParam "query" filteredServices <- runDB $ searchServices category limit' ((page - 1) * limit') query let filteredServices' = sAppAppId . entityVal <$> filteredServices - settings <- getsYesod appSettings + settings <- getsYesod appSettings packageMetadata <- runDB $ fetchPackageMetadata filteredServices' $logInfo $ show packageMetadata - serviceDetailResult <- liftIO $ mapConcurrently (getServiceDetails settings packageMetadata Nothing) filteredServices' - let (errors, services) = partitionEithers serviceDetailResult + serviceDetailResult <- liftIO + $ mapConcurrently (getServiceDetails settings packageMetadata Nothing) filteredServices' + let (_, services) = partitionEithers serviceDetailResult pure $ ServiceAvailableRes services -- if null errors -- then pure $ ServiceAvailableRes services -- else sendResponseStatus status500 ("Errors acquiring service details: " <> show <$> errors) Just packageVersionList -> case eitherDecode $ BS.fromStrict $ encodeUtf8 packageVersionList of -<<<<<<< HEAD Left e -> sendResponseStatus status400 ("could not parse query param \"ids\"" <> show e :: Text) Right (packages :: [PackageVersion]) -> do -- for each item in list get best available from version range - availableServices <- traverse getPackageDetails packages - services <- traverse (uncurry getServiceDetails) availableServices + settings <- getsYesod appSettings + availableServices <- traverse (getPackageDetails settings) packages + packageMetadata <- runDB $ fetchPackageMetadata (snd <$> availableServices) + serviceDetailResult <- liftIO + $ mapConcurrently (uncurry $ getServiceDetails settings packageMetadata) availableServices + let (_, services) = partitionEithers serviceDetailResult pure $ ServiceAvailableRes services - where - getPackageDetails :: PackageVersion -> HandlerFor RegistryCtx (Maybe (Entity SVersion), Entity SApp) - getPackageDetails pv = do - appsDir <- getsYesod $ (( "apps") . resourcesDir) . appSettings - let appId = packageVersionId pv - let spec = packageVersionVersion pv - let appExt = Extension (toS appId) :: Extension "s9pk" - getBestVersion appsDir appExt spec >>= \case - Nothing -> sendResponseStatus - status404 - ("best version could not be found for " <> appId <> " with spec " <> show spec :: Text) - Just v -> do - (service, version) <- runDB $ fetchLatestAppAtVersion appId v >>= errOnNothing - status404 - ("service at version " <> show v <> " not found") - pure (Just version, service) - -getServiceR :: Handler ServiceRes -getServiceR = do - getParameters <- reqGetParams <$> getRequest - (service, version) <- case lookup "id" getParameters of - Nothing -> sendResponseStatus status404 ("id param should exist" :: Text) - Just appId' -> do - case lookup "version" getParameters of - -- default to latest - @TODO need to determine best available based on OS version? - Nothing -> runDB $ fetchLatestApp appId' >>= errOnNothing status404 "service not found" - Just v -> do - case readMaybe v of - Nothing -> sendResponseStatus status400 ("Invalid App Version Specification" :: Text) - Just vv -> runDB $ fetchLatestAppAtVersion appId' vv >>= errOnNothing - status404 - ("service at version " <> show v <> " not found") - getServiceDetails (Just version) service - -getServiceDetails :: Maybe (Entity SVersion) -> Entity SApp -> HandlerFor RegistryCtx ServiceRes -getServiceDetails maybeVersion service = do - (versions, _) <- fetchAllAppVersions (entityKey service) - categories <- runDB $ fetchAppCategories (entityKey service) - (appsDir, appMgrDir) <- getsYesod $ (( "apps") . resourcesDir &&& staticBinDir) . appSettings - domain <- getsYesod $ registryHostname . appSettings - let appId = sAppAppId $ entityVal service - version <- case maybeVersion of - Nothing -> do - (_, version) <- runDB $ fetchLatestApp appId >>= errOnNothing status404 "service not found" - pure $ sVersionNumber $ entityVal version - Just v -> pure $ sVersionNumber $ entityVal v - let appDir = (<> "/") . ( show version) . ( toS appId) $ appsDir - let appExt = Extension (toS appId) :: Extension "s9pk" - manifest' <- handleS9ErrT $ getManifest appMgrDir appDir appExt - manifest <- case eitherDecode $ BS.fromStrict manifest' of - Left e -> do - $logError "could not parse service manifest!" - $logError (show e) - sendResponseStatus status500 ("Internal Server Error" :: Text) - Right a -> pure a - d <- traverse (mapDependencyMetadata appsDir domain) (HM.toList $ serviceManifestDependencies manifest) - pure $ ServiceRes { serviceResIcon = [i|https://#{domain}/package/icon/#{appId}|] - , serviceResManifest = decode $ BS.fromStrict manifest' -- pass through raw JSON Value - , serviceResCategories = serviceCategoryCategoryName . entityVal <$> categories - , serviceResInstructions = [i|https://#{domain}/package/instructions/#{appId}|] - , serviceResLicense = [i|https://#{domain}/package/license/#{appId}|] - , serviceResVersions = versionInfoVersion <$> versions - , serviceResDependencyInfo = HM.fromList d - } - -type URL = Text -mapDependencyMetadata :: (MonadIO m, MonadHandler m) - => FilePath - -> Text - -> (AppIdentifier, ServiceDependencyInfo) - -> m (AppIdentifier, DependencyInfo) -======= - Left e -> sendResponseStatus status400 ("could not parse query param \"ids\"" <> show e :: Text) - Right (packages :: [PackageVersion])-> do - -- for each item in list get best available from version range - settings <- getsYesod appSettings - availableServices <- traverse (getPackageDetails settings) packages - packageMetadata <- runDB $ fetchPackageMetadata (snd <$> availableServices) - serviceDetailResult <- liftIO $ mapConcurrently (uncurry $ getServiceDetails settings packageMetadata) availableServices - let (errors, services) = partitionEithers serviceDetailResult - pure $ ServiceAvailableRes services -- if null errors -- then pure $ ServiceAvailableRes services -- else sendResponseStatus status500 ("Errors acquiring service details: " <> show <$> errors) + + + where - getPackageDetails :: (MonadHandler m) => AppSettings -> PackageVersion -> m (Maybe Version, AppIdentifier) + getPackageDetails :: (MonadHandler m) + => AppSettings + -> PackageVersion + -> m (Maybe Version, AppIdentifier) getPackageDetails settings pv = do - let appId = packageVersionId pv - let spec = packageVersionVersion pv + let appId = packageVersionId pv + let spec = packageVersionVersion pv let appExt = Extension (show appId) :: Extension "s9pk" getBestVersion (( "apps") . resourcesDir $ settings) appExt spec >>= \case - Nothing -> sendResponseStatus status404 ("best version could not be found for " <> show appId <> " with spec " <> show spec :: Text) + Nothing -> sendResponseStatus + status404 + ("best version could not be found for " <> show appId <> " with spec " <> show spec :: Text) Just v -> do pure (Just v, appId) -getServiceDetails :: (MonadIO m, Monad m, MonadError IOException m) => AppSettings -> (HM.HashMap AppIdentifier ([Version], [CategoryTitle])) -> Maybe Version -> AppIdentifier -> m (Either Text ServiceRes) +getServiceDetails :: (MonadIO m, Monad m, MonadError IOException m) + => AppSettings + -> (HM.HashMap AppIdentifier ([Version], [CategoryTitle])) + -> Maybe Version + -> AppIdentifier + -> m (Either Text ServiceRes) getServiceDetails settings metadata maybeVersion appId = do packageMetadata <- case HM.lookup appId metadata of - Nothing-> throwIO $ NotFoundE [i|#{appId} not found.|] - Just m -> pure m + Nothing -> throwIO $ NotFoundE [i|#{appId} not found.|] + Just m -> pure m let (appsDir, appMgrDir) = (( "apps") . resourcesDir &&& staticBinDir) settings - let domain = registryHostname settings + let domain = registryHostname settings version <- case maybeVersion of - Nothing -> do - -- grab first value, which will be the latest version - case fst packageMetadata of - [] -> throwIO $ NotFoundE $ "no latest version found for " <> show appId - x:_ -> pure x - Just v -> pure v + Nothing -> do + -- grab first value, which will be the latest version + case fst packageMetadata of + [] -> throwIO $ NotFoundE $ "no latest version found for " <> show appId + x : _ -> pure x + Just v -> pure v let appDir = (<> "/") . ( show version) . ( show appId) $ appsDir let appExt = Extension (show appId) :: Extension "s9pk" manifest' <- handleS9ErrNuclear $ getManifest appMgrDir appDir appExt case eitherDecode $ BS.fromStrict manifest' of - Left e -> pure $ Left $ "Could not parse service manifest for " <> show appId <> ": " <> show e - Right m -> do - d <- liftIO $ mapConcurrently (mapDependencyMetadata appsDir domain) (HM.toList $ serviceManifestDependencies m) - pure $ Right $ ServiceRes - { serviceResIcon = [i|https://#{domain}/package/icon/#{appId}|] - , serviceResManifest = decode $ BS.fromStrict manifest' -- pass through raw JSON Value - , serviceResCategories = snd packageMetadata - , serviceResInstructions = [i|https://#{domain}/package/instructions/#{appId}|] - , serviceResLicense = [i|https://#{domain}/package/license/#{appId}|] - , serviceResVersions = fst packageMetadata - , serviceResDependencyInfo = HM.fromList $ snd $ partitionEithers d - } + Left e -> pure $ Left $ "Could not parse service manifest for " <> show appId <> ": " <> show e + Right m -> do + d <- liftIO + $ mapConcurrently (mapDependencyMetadata appsDir domain) (HM.toList $ serviceManifestDependencies m) + pure $ Right $ ServiceRes { serviceResIcon = [i|https://#{domain}/package/icon/#{appId}|] + , serviceResManifest = decode $ BS.fromStrict manifest' -- pass through raw JSON Value + , serviceResCategories = snd packageMetadata + , serviceResInstructions = [i|https://#{domain}/package/instructions/#{appId}|] + , serviceResLicense = [i|https://#{domain}/package/license/#{appId}|] + , serviceResVersions = fst packageMetadata + , serviceResDependencyInfo = HM.fromList $ snd $ partitionEithers d + } type URL = Text -mapDependencyMetadata :: (MonadIO m) => FilePath -> Text -> (AppIdentifier, ServiceDependencyInfo) -> m (Either Text (AppIdentifier, DependencyInfo)) ->>>>>>> aggregate query functions +mapDependencyMetadata :: (MonadIO m) + => FilePath + -> Text + -> (AppIdentifier, ServiceDependencyInfo) + -> m (Either Text (AppIdentifier, DependencyInfo)) mapDependencyMetadata appsDir domain (appId, depInfo) = do let ext = (Extension (show appId) :: Extension "s9pk") -- get best version from VersionRange of dependency version <- getBestVersion appsDir ext (serviceDependencyInfoVersion depInfo) >>= \case -<<<<<<< HEAD - Nothing -> sendResponseStatus status404 ("best version not found for dependent package " <> appId :: Text) + Nothing -> throwIO $ NotFoundE $ "best version not found for dependent package " <> show appId Just v -> pure v - pure + pure $ Right ( appId , DependencyInfo { dependencyInfoTitle = appId , dependencyInfoIcon = [i|https://#{domain}/package/icon/#{appId}?spec==#{version}|] } ) -======= - Nothing -> throwIO $ NotFoundE $ "best version not found for dependent package " <> show appId - Just v -> pure v - pure $ Right (appId, DependencyInfo - { dependencyInfoTitle = appId - , dependencyInfoIcon = [i|https://#{domain}/package/icon/#{appId}?spec==#{version}|] - }) ->>>>>>> aggregate query functions decodeIcon :: (MonadHandler m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> m URL decodeIcon appmgrPath depPath e@(Extension icon) = do @@ -530,14 +397,15 @@ fetchAllAppVersions appId = do where mapSVersionToVersionInfo :: [SVersion] -> [VersionInfo] mapSVersionToVersionInfo sv = do - (\v -> VersionInfo { - versionInfoVersion = sVersionNumber v - , versionInfoReleaseNotes = sVersionReleaseNotes v - , versionInfoDependencies = HM.empty - , versionInfoOsRequired = sVersionOsVersionRequired v - , versionInfoOsRecommended = sVersionOsVersionRecommended v - , versionInfoInstallAlert = Nothing - }) <$> sv + (\v -> VersionInfo { versionInfoVersion = sVersionNumber v + , versionInfoReleaseNotes = sVersionReleaseNotes v + , versionInfoDependencies = HM.empty + , versionInfoOsRequired = sVersionOsVersionRequired v + , versionInfoOsRecommended = sVersionOsVersionRecommended v + , versionInfoInstallAlert = Nothing + } + ) + <$> sv fetchMostRecentAppVersions :: MonadIO m => Key SApp -> ReaderT SqlBackend m [Entity SVersion] fetchMostRecentAppVersions appId = select $ do @@ -549,7 +417,6 @@ fetchMostRecentAppVersions appId = select $ do fetchLatestApp :: MonadIO m => AppIdentifier -> ReaderT SqlBackend m (Maybe (P.Entity SApp, P.Entity SVersion)) fetchLatestApp appId = selectOne $ do -<<<<<<< HEAD (service :& version) <- from $ table @SApp @@ -563,18 +430,6 @@ fetchLatestAppAtVersion :: MonadIO m => Text -> Version -> ReaderT SqlBackend m (Maybe (P.Entity SApp, P.Entity SVersion)) -======= - (service :& version) <- - from $ table @SApp - `innerJoin` table @SVersion - `on` (\(service :& version) -> - service ^. SAppId ==. version ^. SVersionAppId) - where_ (service ^. SAppAppId ==. val appId) - orderBy [ desc (version ^. SVersionNumber)] - pure (service, version) - -fetchLatestAppAtVersion :: MonadIO m => AppIdentifier -> Version -> ReaderT SqlBackend m (Maybe (P.Entity SApp, P.Entity SVersion)) ->>>>>>> aggregate query functions fetchLatestAppAtVersion appId version' = selectOne $ do (service :& version) <- from @@ -584,91 +439,39 @@ fetchLatestAppAtVersion appId version' = selectOne $ do where_ $ (service ^. SAppAppId ==. val appId) &&. (version ^. SVersionNumber ==. val version') pure (service, version) -data PackageMetadata = PackageMetadata - { packageMetadataId :: AppIdentifier - , packageMetadataVersions :: [Version] - , packageMetadataCategories :: [CategoryTitle] - } deriving (Eq, Show, Generic) -instance RawSql PackageMetadata where - rawSqlCols _ _ = (3, []) - rawSqlColCountReason _ = "because that is the number of fields in the data type" - rawSqlProcessRow pv = case pv of - [] -> Left "empty row" - _:xs -> Right $ PackageMetadata - { packageMetadataId = case fromPersistValue $ xs !! 1 of - Left _ -> "" - Right v -> v - , packageMetadataVersions = case fromPersistValue $ xs !! 2 of - Left _ -> [] - Right v -> v - , packageMetadataCategories = case fromPersistValue $ xs !! 3 of - Left _ -> [] - Right v -> v - } --- instance FromJSON PackageMetadata where --- parseJSON = withObject "package data" $ \o -> do --- packageMetadataId <- o .: "app_id" --- packageMetadataVersions <- o .: "versions" --- packageMetadataCategories <- o .: "categories" --- pure PackageMetadata { .. } --- instance ToJSON PackageMetadata where --- toJSON PackageMetadata {..} = object --- [ "app_id" .= packageMetadataId --- , "versions" .= packageMetadataVersions --- , "categories" .= packageMetadataCategories --- ] --- instance PersistField PackageMetadata where --- fromPersistValue = fromPersistValueJSON --- toPersistValue = toPersistValueJSON --- instance FromRow PackageMetadata where --- fromRow = PackageMetadata <$> field <*> (fmap Version <$> field) <*> (fmap parseCT <$> field) - -fetchPackageMetadataX :: MonadIO m => [AppIdentifier] -> ReaderT SqlBackend m [PackageMetadata] -fetchPackageMetadataX ids = rawSql "SELECT s.app_id, json_agg(DISTINCT v.number ORDER BY v.number DESC) AS versions, json_agg(DISTINCT c.category_name) AS categories FROM s_app s LEFT JOIN service_category c on s.id = c.service_id JOIN version v on v.app_id = s.id WHERE s.app_id IN (?) GROUP BY s.app_id" [PersistList (toPersistValue <$> ids)] - -fetchPackageMetadata :: MonadUnliftIO m => [AppIdentifier] -> ReaderT SqlBackend m (HM.HashMap AppIdentifier ([Version], [CategoryTitle])) +fetchPackageMetadata :: MonadUnliftIO m + => [AppIdentifier] + -> ReaderT SqlBackend m (HM.HashMap AppIdentifier ([Version], [CategoryTitle])) fetchPackageMetadata ids = do let categoriesQuery = select $ do - (service :& category) <- from $ table @SApp - `leftJoin` table @ServiceCategory - `on` (\(service :& category) -> Database.Esqueleto.Experimental.just (service ^. SAppId) ==. category ?. ServiceCategoryServiceId) - where_ $ - service ^. SAppAppId `in_` valList ids + (service :& category) <- + from + $ table @SApp + `leftJoin` table @ServiceCategory + `on` (\(service :& category) -> + Database.Esqueleto.Experimental.just (service ^. SAppId) + ==. category + ?. ServiceCategoryServiceId + ) + where_ $ service ^. SAppAppId `in_` valList ids 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) - where_ $ - service ^. SAppAppId `in_` valList ids - orderBy [ desc (version ^. SVersionNumber) ] + (service :& version) <- + from + $ table @SApp + `innerJoin` table @SVersion + `on` (\(service :& version) -> (service ^. SAppId) ==. version ^. SVersionAppId) + where_ $ service ^. SAppAppId `in_` valList ids + orderBy [desc (version ^. SVersionNumber)] 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 + c = foreach categories + $ \(appId, categories') -> (unValue appId, catMaybes $ fromMaybe [] (unValue categories')) let v = foreach versions $ \(appId, versions') -> (unValue appId, fromMaybe [] (unValue versions')) - pure $ HM.intersectionWith (\ vers cts -> (vers, cts)) (HM.fromList v) (HM.fromList c) - --- fetchPackageMetadata :: MonadIO m => [AppIdentifier] -> ReaderT SqlBackend m [PackageMetadata] -fetchPackageMetadata_ :: (MonadLogger m, MonadIO m) => [AppIdentifier] -> AppSettings -> m [PackageMetadata] -fetchPackageMetadata_ ids settings = do - let connString = PP.pgConnStr $ appDatabaseConf settings - conn <- liftIO $ PS.connectPostgreSQL connString - res <- liftIO $ PS.query conn query $ PS.Only $ PS.In ids - $logInfo $ show query - $logInfo$ show res - $logInfo$ show ids - forM res $ \(appId, versions, categories) -> - pure $ PackageMetadata - { packageMetadataId = appId - , packageMetadataVersions = versions - , packageMetadataCategories = categories - } - where - query :: PS.Query - query = "SELECT s.app_id, json_agg(DISTINCT v.number ORDER BY v.number DESC) AS versions, json_agg(DISTINCT c.category_name) AS categories FROM s_app s LEFT JOIN service_category c on s.id = c.service_id JOIN version v on v.app_id = s.id WHERE s.app_id IN ? GROUP BY s.app_id" - -- query = "SELECT \"s_app\".\"app_id\", json_agg(DISTINCT \"version\".\"number\" ORDER BY \"version\".\"number\" DESC) AS \"versions\", json_agg(DISTINCT \"service_category\".\"category_name\") AS \"categories\" FROM \"s_app\" LEFT JOIN \"service_category\" on \"s_app\".\"id\" = \"service_category\".\"service_id\" JOIN \"version\" on \"version\".\"app_id\" = \"s_app\".\"id\" WHERE \"s_app\".\"app_id\" IN ? GROUP BY \"s_app\".\"app_id\"" + pure $ HM.intersectionWith (\vers cts -> (vers, cts)) (HM.fromList v) (HM.fromList c) fetchAppCategories :: MonadIO m => Key SApp -> ReaderT SqlBackend m [P.Entity ServiceCategory] fetchAppCategories appId = select $ do @@ -682,7 +485,6 @@ fetchAppCategories appId = select $ do mapEntityToStoreApp :: MonadIO m => Entity SApp -> ReaderT SqlBackend m StoreApp mapEntityToStoreApp serviceEntity = do -<<<<<<< HEAD let service = entityVal serviceEntity entityVersion <- fetchMostRecentAppVersions $ entityKey serviceEntity let vers = entityVal <$> entityVersion @@ -694,38 +496,23 @@ mapEntityToStoreApp serviceEntity = do , storeAppIconType = sAppIconType service , storeAppTimestamp = Just (sAppCreatedAt service) -- case on if updatedAt? or always use updated time? was file timestamp } + where + mapSVersionToVersionInfo :: [SVersion] -> [VersionInfo] + mapSVersionToVersionInfo sv = do + (\v -> VersionInfo { versionInfoVersion = sVersionNumber v + , versionInfoReleaseNotes = sVersionReleaseNotes v + , versionInfoDependencies = HM.empty + , versionInfoOsRequired = sVersionOsVersionRequired v + , versionInfoOsRecommended = sVersionOsVersionRecommended v + , versionInfoInstallAlert = Nothing + } + ) + <$> sv mapEntityToServiceAvailable :: (MonadIO m, MonadHandler m) => Text -> Entity SApp -> ReaderT SqlBackend m ServiceAvailable -======= - let service = entityVal serviceEntity - entityVersion <- fetchMostRecentAppVersions $ entityKey serviceEntity - let vers = entityVal <$> entityVersion - let vv = mapSVersionToVersionInfo vers - pure $ StoreApp { - storeAppTitle = sAppTitle service - , storeAppDescShort = sAppDescShort service - , storeAppDescLong = sAppDescLong service - , storeAppVersionInfo = NE.fromList vv - , storeAppIconType = sAppIconType service - , storeAppTimestamp = Just (sAppCreatedAt service) -- case on if updatedAt? or always use updated time? was file timestamp - } - where - mapSVersionToVersionInfo :: [SVersion] -> [VersionInfo] - mapSVersionToVersionInfo sv = do - (\v -> VersionInfo { - versionInfoVersion = sVersionNumber v - , versionInfoReleaseNotes = sVersionReleaseNotes v - , versionInfoDependencies = HM.empty - , versionInfoOsRequired = sVersionOsVersionRequired v - , versionInfoOsRecommended = sVersionOsVersionRecommended v - , versionInfoInstallAlert = Nothing - }) <$> sv - -mapEntityToServiceAvailable :: (MonadIO m, MonadHandler m) => Text -> Entity SApp -> ReaderT SqlBackend m ServiceAvailable ->>>>>>> aggregate query functions mapEntityToServiceAvailable domain service = do let appId = sAppAppId $ entityVal service (_, v) <- fetchLatestApp appId >>= errOnNothing status404 "service not found" diff --git a/src/Lib/External/AppMgr.hs b/src/Lib/External/AppMgr.hs index f5c9784..d7f74d7 100644 --- a/src/Lib/External/AppMgr.hs +++ b/src/Lib/External/AppMgr.hs @@ -59,7 +59,7 @@ getManifest appmgrPath appPath e@(Extension appId) = do ExitFailure n -> throwE $ AppMgrE [i|embassy-sdk inspect manifest #{appId}|] n getIcon :: (MonadIO m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> S9ErrT m ByteString -getIcon appmgrPath appPath e@(Extension icon) = do +getIcon appmgrPath appPath (Extension icon) = do (ec, bs) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "icon", appPath] "" case ec of ExitSuccess -> pure bs @@ -73,14 +73,14 @@ getPackageHash appmgrPath appPath e@(Extension appId) = do ExitFailure n -> throwE $ AppMgrE [i|embassy-sdk inspect hash #{appId}|] n getInstructions :: (MonadIO m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> S9ErrT m ByteString -getInstructions appmgrPath appPath e@(Extension appId) = do +getInstructions appmgrPath appPath (Extension appId) = do (ec, bs) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "instructions", appPath] "" case ec of ExitSuccess -> pure bs ExitFailure n -> throwE $ AppMgrE [i|embassy-sdk inspect instructions #{appId}|] n getLicense :: (MonadIO m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> S9ErrT m ByteString -getLicense appmgrPath appPath e@(Extension appId) = do +getLicense appmgrPath appPath (Extension appId) = do (ec, bs) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "license", appPath] "" case ec of ExitSuccess -> pure bs diff --git a/src/Lib/Types/AppIndex.hs b/src/Lib/Types/AppIndex.hs index 17d45c6..4ed9499 100644 --- a/src/Lib/Types/AppIndex.hs +++ b/src/Lib/Types/AppIndex.hs @@ -27,9 +27,6 @@ import Yesod import Data.Functor.Contravariant ( Contravariant(contramap) ) import qualified GHC.Read ( Read(..) ) import qualified GHC.Show ( Show(..) ) -import Database.PostgreSQL.Simple.ToField -import Database.PostgreSQL.Simple.FromField -import Data.Binary.Builder newtype AppIdentifier = AppIdentifier { unAppIdentifier :: Text } deriving (Eq) @@ -62,13 +59,6 @@ instance ToContent AppIdentifier where toContent = toContent . toJSON instance ToTypedContent AppIdentifier where toTypedContent = toTypedContent . toJSON -instance ToField AppIdentifier where - toField a = toJSONField a - -- Escape $ BS.toStrict $ encode a - -- Plain $ inQuotes $ putStringUtf8 $ show a - -- $ fromByteString $ BS.toStrict $ encode a -instance FromField AppIdentifier where - fromField = fromJSONField data VersionInfo = VersionInfo { versionInfoVersion :: Version diff --git a/src/Lib/Types/Category.hs b/src/Lib/Types/Category.hs index 80ee041..13f9b47 100644 --- a/src/Lib/Types/Category.hs +++ b/src/Lib/Types/Category.hs @@ -8,8 +8,6 @@ import Database.Persist.Postgresql import Data.Aeson import Control.Monad import Yesod.Core -import Database.PostgreSQL.Simple.FromField -import Database.PostgreSQL.Simple.ToField data CategoryTitle = FEATURED | BITCOIN @@ -47,6 +45,7 @@ instance FromJSON CategoryTitle where instance ToContent CategoryTitle where toContent = toContent . toJSON instance ToTypedContent CategoryTitle where +<<<<<<< HEAD toTypedContent = toTypedContent . toJSON <<<<<<< HEAD ======= @@ -68,3 +67,6 @@ parseCT = \case "alt coin" -> ALTCOIN -- _ -> fail "unknown category title" >>>>>>> aggregate query functions +======= + toTypedContent = toTypedContent . toJSON +>>>>>>> clean up From e302d6304635e2bbd235edc51a47c1350db7a6f3 Mon Sep 17 00:00:00 2001 From: Lucy Cifferello <12953208+elvece@users.noreply.github.com> Date: Wed, 22 Sep 2021 11:04:58 -0600 Subject: [PATCH 03/48] fix tests --- config/routes | 3 - resources/icons/bitcoind.png | 0 resources/sys/agent/0.0.0/agent | 0 resources/sys/image/0.0.0/image.img.deleteme | 1 - src/Model.hs | 2 +- test/Handler/AppSpec.hs | 69 ++++++++++---------- test/Handler/MarketplaceSpec.hs | 60 +++++++++-------- 7 files changed, 66 insertions(+), 69 deletions(-) delete mode 100644 resources/icons/bitcoind.png delete mode 100644 resources/sys/agent/0.0.0/agent delete mode 100644 resources/sys/image/0.0.0/image.img.deleteme diff --git a/config/routes b/config/routes index dc4abc5..c3d7c57 100644 --- a/config/routes +++ b/config/routes @@ -13,9 +13,6 @@ -- TODO confirm needed /package/config/#AppIdentifier AppConfigR GET -- get app config from appmgr -- ?spec={semver-spec} /package/version/#Text VersionAppR GET -- get most recent appId version - - --- TODO deprecate !/sys/#SYS_EXTENSIONLESS SysR GET -- get most recent sys app -- ?spec={semver-spec} /version VersionR GET /sys/version/#Text VersionSysR GET -- get most recent sys app version diff --git a/resources/icons/bitcoind.png b/resources/icons/bitcoind.png deleted file mode 100644 index e69de29..0000000 diff --git a/resources/sys/agent/0.0.0/agent b/resources/sys/agent/0.0.0/agent deleted file mode 100644 index e69de29..0000000 diff --git a/resources/sys/image/0.0.0/image.img.deleteme b/resources/sys/image/0.0.0/image.img.deleteme deleted file mode 100644 index 478ae3e..0000000 --- a/resources/sys/image/0.0.0/image.img.deleteme +++ /dev/null @@ -1 +0,0 @@ -image downloaded \ No newline at end of file diff --git a/src/Model.hs b/src/Model.hs index 11de26f..b2dacd9 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -64,8 +64,8 @@ Category name CategoryTitle parent CategoryId Maybe description Text - UniqueName name priority Int default=0 + UniqueName name deriving Eq deriving Show diff --git a/test/Handler/AppSpec.hs b/test/Handler/AppSpec.hs index 46b860e..893afd2 100644 --- a/test/Handler/AppSpec.hs +++ b/test/Handler/AppSpec.hs @@ -14,68 +14,65 @@ import Model spec :: Spec spec = do - describe "GET /apps" $ withApp $ it "returns list of apps" $ do + describe "GET /package/index" $ withApp $ it "returns list of apps" $ do request $ do setMethod "GET" - setUrl ("/apps" :: Text) - bodyContains "bitcoind" - bodyContains "version: 0.18.1" + setUrl ("/package/index" :: Text) + bodyContains "embassy-pages" + bodyContains "version: 0.1.3" statusIs 200 - describe "GET /apps/:appId with unknown version spec for bitcoin" $ withApp $ it "fails to get unknown app" $ do + describe "GET /package/:appId with unknown version spec for embassy-pages" + $ withApp + $ it "fails to get unknown app" + $ do + request $ do + setMethod "GET" + setUrl ("/package/embassy-pages.s9pk?spec=0.1.4" :: Text) + statusIs 404 + describe "GET /package/:appId with unknown app" $ withApp $ it "fails to get an unregistered app" $ do request $ do setMethod "GET" - setUrl ("/apps/bitcoind.s9pk?spec=0.18.3" :: Text) + setUrl ("/package/tempapp.s9pk?spec=0.0.1" :: Text) statusIs 404 - describe "GET /apps/:appId with unknown app" $ withApp $ it "fails to get an unregistered app" $ do - request $ do - setMethod "GET" - setUrl ("/apps/tempapp.s9pk?spec=0.0.1" :: Text) - statusIs 404 - describe "GET /apps/:appId with existing version spec for bitcoin" + describe "GET /package/:appId with existing version spec for embassy-pages" $ withApp $ it "creates app and metric records" $ do request $ do setMethod "GET" - setUrl ("/apps/bitcoind.s9pk?spec==0.18.1" :: Text) + setUrl ("/package/embassy-pages.s9pk?spec==0.1.3" :: Text) statusIs 200 - apps <- runDBtest $ selectList [SAppAppId ==. "bitcoind"] [] + apps <- runDBtest $ selectList [SAppAppId ==. "embassy-pages"] [] assertEq "app should exist" (length apps) 1 let app = fromJust $ head apps metrics <- runDBtest $ selectList [MetricAppId ==. entityKey app] [] assertEq "metric should exist" (length metrics) 1 - describe "GET /apps/:appId with existing version spec for cups" $ withApp $ it "creates app and metric records" $ do - request $ do - setMethod "GET" - setUrl ("/apps/cups.s9pk?spec=0.2.1" :: Text) - statusIs 200 - apps <- runDBtest $ selectList [SAppAppId ==. "cups"] [] - assertEq "app should exist" (length apps) 1 - let app = fromJust $ head apps - metrics <- runDBtest $ selectList [MetricAppId ==. entityKey app] [] - assertEq "metric should exist" (length metrics) 1 - version <- runDBtest $ selectList [SVersionAppId ==. entityKey app] [] - assertEq "version should exist" (length version) 1 + describe "GET /package/:appId with existing version spec for filebrowser" + $ withApp + $ it "creates app and metric records" + $ do + request $ do + setMethod "GET" + setUrl ("/package/filebrowser.s9pk?spec==2.14.1.1" :: Text) + statusIs 200 + apps <- runDBtest $ selectList [SAppAppId ==. "filebrowser"] [] + assertEq "app should exist" (length apps) 1 + let app = fromJust $ head apps + metrics <- runDBtest $ selectList [MetricAppId ==. entityKey app] [] + assertEq "metric should exist" (length metrics) 1 + version <- runDBtest $ selectList [SVersionAppId ==. entityKey app] [] + assertEq "version should exist" (length version) 1 describe "GET /sys/proxy.pac" $ withApp $ it "does not record metric but request successful" $ do request $ do setMethod "GET" setUrl ("/sys/proxy.pac?spec=0.1.0" :: Text) statusIs 200 - -- select * from s_app apps <- runDBtest $ selectList ([] :: [Filter SApp]) [] assertEq "no apps should exist" (length apps) 0 describe "GET /sys/:sysId" $ withApp $ it "does not record metric but request successful" $ do request $ do setMethod "GET" - setUrl ("/sys/agent?spec=0.0.0" :: Text) + setUrl ("/sys/appmgr?spec=0.0.0" :: Text) statusIs 200 apps <- runDBtest $ selectList ([] :: [Filter SApp]) [] assertEq "no apps should exist" (length apps) 0 - -- @TODO uncomment when new portable appmgr live - xdescribe "GET /apps/manifest/#S9PK" $ withApp $ it "gets bitcoin manifest" $ do - request $ do - setMethod "GET" - setUrl ("/apps/manifest/bitcoind?spec==0.20.1" :: Text) - statusIs 200 - bodyContains - "{\"id\":\"bitcoind\",\"version\":\"0.20.1\",\"title\":\"Bitcoin Core\",\"description\":{\"short\":\"Bitcoin Full Node by Bitcoin Core\",\"long\":\"Bitcoin is an innovative payment network and a new kind of money. Bitcoin uses peer-to-peer technology to operate with no central authority or banks; managing transactions and the issuing of bitcoins is carried out collectively by the network. Bitcoin is open-source; its design is public, nobody owns or controls Bitcoin and everyone can take part. Through many of its unique properties, Bitcoin allows exciting uses that could not be covered by any previous payment system.\"},\"release-notes\":\"https://github.com/bitcoin/bitcoin/blob/master/doc/release-notes/release-notes-0.20.1.md\",\"has-instructions\":true,\"os-version-required\":\">=0.2.4\",\"os-version-recommended\":\">=0.2.4\",\"ports\":[{\"internal\":8332,\"tor\":8332},{\"internal\":8333,\"tor\":8333}],\"image\":{\"type\":\"tar\"},\"mount\":\"/root/.bitcoin\",\"assets\":[{\"src\":\"bitcoin.conf.template\",\"dst\":\".\",\"overwrite\":true}],\"hidden-service-version\":\"v2\",\"dependencies\":{}}" diff --git a/test/Handler/MarketplaceSpec.hs b/test/Handler/MarketplaceSpec.hs index c7d87f8..c81743f 100644 --- a/test/Handler/MarketplaceSpec.hs +++ b/test/Handler/MarketplaceSpec.hs @@ -33,14 +33,14 @@ spec = do "short desc lnd" "long desc lnd" "png" - featuredCat <- runDBtest $ insert $ Category time FEATURED Nothing "desc" - btcCat <- runDBtest $ insert $ Category time BITCOIN Nothing "desc" - lnCat <- runDBtest $ insert $ Category time LIGHTNING Nothing "desc" + featuredCat <- runDBtest $ insert $ Category time FEATURED Nothing "desc" 0 + btcCat <- runDBtest $ insert $ Category time BITCOIN Nothing "desc" 0 + lnCat <- runDBtest $ insert $ Category time LIGHTNING Nothing "desc" 0 _ <- runDBtest $ insert_ $ ServiceCategory time btc featuredCat "bitcoin" FEATURED Nothing _ <- 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 FEATURED 20 0 "" + apps <- runDBtest $ searchServices (Just FEATURED) 20 0 "" assertEq "should exist" (length apps) 1 let app' = fromJust $ head apps assertEq "should be bitcoin" (sAppTitle $ entityVal app') "Bitcoin Core" @@ -60,14 +60,14 @@ spec = do "short desc lnd" "long desc lnd" "png" - featuredCat <- runDBtest $ insert $ Category time FEATURED Nothing "desc" - btcCat <- runDBtest $ insert $ Category time BITCOIN Nothing "desc" - lnCat <- runDBtest $ insert $ Category time LIGHTNING Nothing "desc" - _ <- runDBtest $ insert_ $ ServiceCategory time btc featuredCat "bitcoin" FEATURED Nothing + featuredCat <- runDBtest $ insert $ Category time FEATURED Nothing "desc" 0 + btcCat <- runDBtest $ insert $ Category time BITCOIN Nothing "desc" 0 + lnCat <- runDBtest $ insert $ Category time LIGHTNING Nothing "desc" 0 + _ <- runDBtest $ insert_ $ ServiceCategory time btc featuredCat "bitcoind" FEATURED Nothing _ <- 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 BITCOIN 20 0 "" + _ <- runDBtest $ insert_ $ ServiceCategory time btc btcCat "bitcoind" BITCOIN Nothing + apps <- runDBtest $ searchServices (Just BITCOIN) 20 0 "" assertEq "should exist" (length apps) 2 describe "searchServices with fuzzy query" $ withApp @@ -88,10 +88,10 @@ spec = do "short desc" "lightning long desc" "png" - cate <- runDBtest $ insert $ Category time FEATURED Nothing "desc" + 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 FEATURED 20 0 "lightning" + apps <- runDBtest $ searchServices (Just FEATURED) 20 0 "lightning" assertEq "should exist" (length apps) 1 let app' = fromJust $ head apps print app' @@ -104,8 +104,9 @@ spec = do "short desc bitcoin" "long desc bitcoin" "png" - _ <- runDBtest $ insert $ SVersion time (Just time) btc "0.19.0" "notes" Any Any - _ <- runDBtest $ insert $ SVersion time (Just time) btc "0.20.0" "notes" Any Any + print btc + _ <- runDBtest $ insert $ SVersion time (Just time) btc "0.19.0" "notes" Any Any Nothing + _ <- runDBtest $ insert $ SVersion time (Just time) btc "0.20.0" "notes" Any Any Nothing lnd <- runDBtest $ insert $ SApp time (Just time) "Lightning Network Daemon" @@ -113,22 +114,25 @@ spec = do "short desc lnd" "long desc lnd" "png" - _ <- runDBtest $ insert $ SVersion time (Just time) lnd "0.18.0" "notes" Any Any - _ <- runDBtest $ insert $ SVersion time (Just time) lnd "0.17.0" "notes" Any Any - featuredCat <- runDBtest $ insert $ Category time FEATURED Nothing "desc" - btcCat <- runDBtest $ insert $ Category time BITCOIN Nothing "desc" - lnCat <- runDBtest $ insert $ Category time LIGHTNING Nothing "desc" + _ <- runDBtest $ insert $ SVersion time (Just time) lnd "0.18.0" "notes" Any Any Nothing + _ <- runDBtest $ insert $ SVersion time (Just time) lnd "0.17.0" "notes" Any Any Nothing + featuredCat <- runDBtest $ insert $ Category time FEATURED Nothing "desc" 0 + btcCat <- runDBtest $ insert $ Category time BITCOIN Nothing "desc" 0 + lnCat <- runDBtest $ insert $ Category time LIGHTNING Nothing "desc" 0 _ <- runDBtest $ insert_ $ ServiceCategory time btc featuredCat "bitcoin" FEATURED Nothing _ <- 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 ANY 20 0 "" + apps <- runDBtest $ searchServices Nothing 20 0 "" assertEq "should exist" (length apps) 2 - -- describe "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" "*" "*" - -- _ <- runDBtest $ insert $ SVersion time Nothing app "0.20.0.0" "release notes 0.19.0.0" "*" "*" - -- res <- runDBtest $ getServiceVersionsWithReleaseNotes "bitcoin" - -- print res + 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 + -- res <- runDBtest $ getServiceVersionsWithReleaseNotes "bitcoin" + -- print res + print () From 27cbe565b38692acf978e8f8ba656408a578497b Mon Sep 17 00:00:00 2001 From: Lucy Cifferello <12953208+elvece@users.noreply.github.com> Date: Wed, 22 Sep 2021 20:57:33 -0600 Subject: [PATCH 04/48] limit strict bs converstion and refactor to not use fs read --- .gitignore | 3 +- resources/apps/apps.yaml | 163 ------------------------------------- src/Handler/Icons.hs | 8 +- src/Handler/Marketplace.hs | 61 +++++++++----- src/Lib/External/AppMgr.hs | 17 ++-- src/Lib/Types/AppIndex.hs | 2 +- src/Util/Shared.hs | 3 +- 7 files changed, 56 insertions(+), 201 deletions(-) delete mode 100644 resources/apps/apps.yaml diff --git a/.gitignore b/.gitignore index 6297b19..b7446d9 100644 --- a/.gitignore +++ b/.gitignore @@ -30,4 +30,5 @@ version **/*.s9pk **/appmgr 0.3.0_features.md -**/embassy-sdk \ No newline at end of file +**/embassy-sdk +start9-registry.prof \ No newline at end of file diff --git a/resources/apps/apps.yaml b/resources/apps/apps.yaml deleted file mode 100644 index ea0e93b..0000000 --- a/resources/apps/apps.yaml +++ /dev/null @@ -1,163 +0,0 @@ -bitcoind: - title: Bitcoin Core - icon-type: png - description: - long: Bitcoin is an innovative payment network and a new kind of money. Bitcoin - uses peer-to-peer technology to operate with no central authority or banks; - managing transactions and the issuing of bitcoins is carried out collectively - by the network. Bitcoin is open-source; its design is public, nobody owns or - controls Bitcoin and everyone can take part. Through many of its unique properties, - Bitcoin allows exciting uses that could not be covered by any previous payment - system. - short: A Bitcoin Full Node by Bitcoin Core - version-info: - - os-version-required: '>=0.2.5' - release-notes: https://github.com/bitcoin/bitcoin/blob/master/doc/release-notes/release-notes-0.20.1.md - dependencies: {} - version: 0.20.1.1 - os-version-recommended: '>=0.2.5' - - os-version-required: '>=0.2.4' - release-notes: https://github.com/bitcoin/bitcoin/blob/master/doc/release-notes/release-notes-0.20.1.md - dependencies: {} - version: 0.20.1 - os-version-recommended: '>=0.2.4' - - os-version-required: '*' - release-notes: https://github.com/bitcoin/bitcoin/blob/master/doc/release-notes/release-notes-0.20.0.md - dependencies: {} - version: 0.20.0 - os-version-recommended: '*' - - os-version-required: '*' - release-notes: https://github.com/bitcoin/bitcoin/blob/master/doc/release-notes/release-notes-0.19.1.md - dependencies: {} - version: 0.19.1 - os-version-recommended: '*' - - os-version-required: '*' - release-notes: https://github.com/bitcoin/bitcoin/blob/master/doc/release-notes/release-notes-0.19.0.1.md - dependencies: {} - version: 0.19.0 - os-version-recommended: '*' - - os-version-required: '*' - release-notes: https://github.com/bitcoin/bitcoin/blob/master/doc/release-notes/release-notes-0.18.1.md - dependencies: {} - version: 0.18.1 - os-version-recommended: '*' -cups: - title: Cups Messenger - icon-type: png - description: - long: Cups is a private, self-hosted, peer-to-peer, Tor-based, instant messenger. - Unlike other end-to-end encrypted messengers, with Cups on the Embassy there - are no trusted third parties. - short: Real private messaging - version-info: - - os-version-required: '>=0.2.4' - release-notes: | - Features - - Adds instructions defined by EmbassyOS 0.2.4 instructions feature - dependencies: {} - version: 0.3.6 - os-version-recommended: '>=0.2.4' - - os-version-required: '*' - release-notes: | - Bug Fixes - - Upgrade UI to gracefully handle Consulate browser - dependencies: {} - version: 0.3.5 - os-version-recommended: '*' - - os-version-required: '*' - release-notes: | - Bug Fixes - - Register a SIGTERM handler for graceful shutdown - dependencies: {} - version: 0.3.4 - os-version-recommended: '*' - - os-version-required: '*' - release-notes: | - Features - - Conversation manual refresh - Bug Fixes - - Contacts hilighting for unread messages - - Avatar first initial centering - - Styling improvements - dependencies: {} - version: 0.3.3 - os-version-recommended: '*' - - os-version-required: '*' - release-notes: | - Features - - Conversation manual refresh - Bug Fixes - - Contacts hilighting for unread messages - - Avatar first initial centering - - Styling improvements - dependencies: {} - version: 0.3.2 - os-version-recommended: '*' - - os-version-required: '*' - release-notes: | - Big UX overhaul, including the code requisite to power the new Cups Messenger mobile application. - Check out "Cups Messenger" on the iOS and Google Play store - - Usable from your phone without the Tor browser. - - New Dark Theme. - - Message Previews + Old conversation removal - - Fixes bugs from 0.3.0 - dependencies: {} - version: 0.3.1 - os-version-recommended: '*' - - os-version-required: '*' - release-notes: | - Big UX overhaul, including the code requisite to power the new Cups Messenger mobile application. - Check out "Cups Messenger" on the iOS and Google Play store - - Usable from your phone without the Tor browser. - - New Dark Theme. - - Message Previews + Old conversation removal - dependencies: {} - version: 0.3.0 - os-version-recommended: '*' - - os-version-required: '*' - release-notes: Added headers for Consulate caching - dependencies: {} - version: 0.2.4 - os-version-recommended: '*' - - os-version-required: '*' - release-notes: fix autofill for password field - dependencies: {} - version: 0.2.3 - os-version-recommended: '*' - - os-version-required: '*' - release-notes: | - - Massive load-time improvements - dependencies: {} - version: 0.2.2 - os-version-recommended: '*' - - os-version-required: '*' - release-notes: | - - Signin security improvements - dependencies: {} - version: 0.2.1 - os-version-recommended: '*' - - os-version-required: '*' - release-notes: | - # Cups UI released - - Breaks compatibility with cups-cli 0.1.x - dependencies: {} - version: 0.2.0 - os-version-recommended: '*' - - os-version-required: '*' - release-notes: | - # Alpha Release - - Send messages - - Recieve messages - - Contact book - dependencies: {} - version: 0.1.1 - os-version-recommended: '*' - - os-version-required: '*' - release-notes: | - # Alpha Release - - Send messages - - Recieve messages - - Contact book - dependencies: {} - version: 0.1.0 - os-version-recommended: '*' \ No newline at end of file diff --git a/src/Handler/Icons.hs b/src/Handler/Icons.hs index 87c6925..030ba8b 100644 --- a/src/Handler/Icons.hs +++ b/src/Handler/Icons.hs @@ -41,7 +41,7 @@ getIconsR appId = do Just v -> pure v let appDir = (<> "/") . ( show spec) . ( toS appId) $ appsDir manifest' <- handleS9ErrT $ getManifest appMgrDir appDir ext - manifest <- case eitherDecode $ BS.fromStrict manifest' of + manifest <- case eitherDecode manifest' of Left e -> do $logError "could not parse service manifest!" $logError (show e) @@ -61,7 +61,7 @@ getIconsR appId = do SVG -> pure typeSvg JPG -> pure typeJpeg JPEG -> pure typeJpeg - respondSource mimeType (sendChunkBS =<< handleS9ErrT (getIcon appMgrDir (appDir show ext) ext)) + respondSource mimeType (sendChunkBS =<< BS.toStrict <$> handleS9ErrT (getIcon appMgrDir (appDir show ext) ext)) -- (_, Just hout, _, _) <- liftIO (createProcess $ iconBs { std_out = CreatePipe }) -- respondSource typePlain (runConduit $ yieldMany () [iconBs]) -- respondSource typePlain $ sourceHandle hout .| awaitForever sendChunkBS @@ -77,7 +77,7 @@ getLicenseR appId = do case servicePath of Nothing -> notFound Just p -> do - respondSource typePlain (sendChunkBS =<< handleS9ErrT (getLicense appMgrDir p ext)) + respondSource typePlain (sendChunkBS =<< BS.toStrict <$> handleS9ErrT (getLicense appMgrDir p ext)) where ext = Extension (show appId) :: Extension "s9pk" getInstructionsR :: AppIdentifier -> Handler TypedContent @@ -90,5 +90,5 @@ getInstructionsR appId = do case servicePath of Nothing -> notFound Just p -> do - respondSource typePlain (sendChunkBS =<< handleS9ErrT (getInstructions appMgrDir p ext)) + respondSource typePlain (sendChunkBS =<< BS.toStrict <$> handleS9ErrT (getInstructions appMgrDir p ext)) where ext = Extension (show appId) :: Extension "s9pk" diff --git a/src/Handler/Marketplace.hs b/src/Handler/Marketplace.hs index 6db53a1..c5dc3ff 100644 --- a/src/Handler/Marketplace.hs +++ b/src/Handler/Marketplace.hs @@ -43,7 +43,9 @@ import Util.Shared import Lib.Types.AppIndex ( ) import UnliftIO.Async import Database.Esqueleto.PostgreSQL ( arrayAggDistinct ) +import Data.Semigroup +type URL = Text newtype CategoryRes = CategoryRes { categories :: [CategoryTitle] } deriving (Show, Generic) @@ -283,11 +285,14 @@ getPackageListR = do Left e -> sendResponseStatus status400 ("could not parse query param \"ids\"" <> show e :: Text) Right (packages :: [PackageVersion]) -> do -- for each item in list get best available from version range - settings <- getsYesod appSettings - availableServices <- traverse (getPackageDetails settings) packages + settings <- getsYesod appSettings + availableServicesResult <- liftIO $ mapConcurrently (getPackageDetails settings) packages + -- @TODO fix _ error + let (_, availableServices) = partitionEithers availableServicesResult packageMetadata <- runDB $ fetchPackageMetadata (snd <$> availableServices) serviceDetailResult <- liftIO $ mapConcurrently (uncurry $ getServiceDetails settings packageMetadata) availableServices + -- @TODO fix _ error let (_, services) = partitionEithers serviceDetailResult pure $ ServiceAvailableRes services -- if null errors @@ -296,21 +301,28 @@ getPackageListR = do + + + where - getPackageDetails :: (MonadHandler m) + getPackageDetails :: (MonadIO m) => AppSettings -> PackageVersion - -> m (Maybe Version, AppIdentifier) + -> m (Either Text ((Maybe Version), AppIdentifier)) getPackageDetails settings pv = do let appId = packageVersionId pv let spec = packageVersionVersion pv let appExt = Extension (show appId) :: Extension "s9pk" getBestVersion (( "apps") . resourcesDir $ settings) appExt spec >>= \case - Nothing -> sendResponseStatus - status404 - ("best version could not be found for " <> show appId <> " with spec " <> show spec :: Text) + Nothing -> + pure + $ Left + $ "best version could not be found for " + <> show appId + <> " with spec " + <> show spec Just v -> do - pure (Just v, appId) + pure $ Right (Just v, appId) getServiceDetails :: (MonadIO m, Monad m, MonadError IOException m) => AppSettings @@ -334,13 +346,13 @@ getServiceDetails settings metadata maybeVersion appId = do let appDir = (<> "/") . ( show version) . ( show appId) $ appsDir let appExt = Extension (show appId) :: Extension "s9pk" manifest' <- handleS9ErrNuclear $ getManifest appMgrDir appDir appExt - case eitherDecode $ BS.fromStrict manifest' of + case eitherDecode $ manifest' of Left e -> pure $ Left $ "Could not parse service manifest for " <> show appId <> ": " <> show e Right m -> do d <- liftIO - $ mapConcurrently (mapDependencyMetadata appsDir domain) (HM.toList $ serviceManifestDependencies m) + $ mapConcurrently (mapDependencyMetadata domain metadata) (HM.toList $ serviceManifestDependencies m) pure $ Right $ ServiceRes { serviceResIcon = [i|https://#{domain}/package/icon/#{appId}|] - , serviceResManifest = decode $ BS.fromStrict manifest' -- pass through raw JSON Value + , serviceResManifest = decode $ manifest' -- pass through raw JSON Value , serviceResCategories = snd packageMetadata , serviceResInstructions = [i|https://#{domain}/package/instructions/#{appId}|] , serviceResLicense = [i|https://#{domain}/package/license/#{appId}|] @@ -349,16 +361,19 @@ getServiceDetails settings metadata maybeVersion appId = do } -type URL = Text mapDependencyMetadata :: (MonadIO m) - => FilePath - -> Text + => Text + -> HM.HashMap AppIdentifier ([Version], [CategoryTitle]) -> (AppIdentifier, ServiceDependencyInfo) -> m (Either Text (AppIdentifier, DependencyInfo)) -mapDependencyMetadata appsDir domain (appId, depInfo) = do - let ext = (Extension (show appId) :: Extension "s9pk") +mapDependencyMetadata domain metadata (appId, depInfo) = do + depMetadata <- 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 - version <- getBestVersion appsDir ext (serviceDependencyInfoVersion depInfo) >>= \case + let satisfactory = filter (<|| serviceDependencyInfoVersion depInfo) (fst depMetadata) + let best = getMax <$> foldMap (Just . Max) satisfactory + version <- case best of Nothing -> throwIO $ NotFoundE $ "best version not found for dependent package " <> show appId Just v -> pure v pure $ Right @@ -371,7 +386,7 @@ mapDependencyMetadata appsDir domain (appId, depInfo) = do decodeIcon :: (MonadHandler m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> m URL decodeIcon appmgrPath depPath e@(Extension icon) = do icon' <- handleS9ErrT $ getIcon appmgrPath depPath e - case eitherDecode $ BS.fromStrict icon' of + case eitherDecode icon' of Left e' -> do $logInfo $ T.pack e' sendResponseStatus status400 e' @@ -380,12 +395,12 @@ decodeIcon appmgrPath depPath e@(Extension icon) = do decodeInstructions :: (MonadHandler m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> m Text decodeInstructions appmgrPath depPath package = do instructions <- handleS9ErrT $ getInstructions appmgrPath depPath package - pure $ decodeUtf8 instructions + pure $ decodeUtf8 $ BS.toStrict instructions decodeLicense :: (MonadHandler m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> m Text decodeLicense appmgrPath depPath package = do license <- handleS9ErrT $ getLicense appmgrPath depPath package - pure $ decodeUtf8 license + pure $ decodeUtf8 $ BS.toStrict license fetchAllAppVersions :: Key SApp -> HandlerFor RegistryCtx ([VersionInfo], ReleaseNotes) fetchAllAppVersions appId = do @@ -453,7 +468,8 @@ fetchPackageMetadata ids = do ==. category ?. ServiceCategoryServiceId ) - where_ $ service ^. SAppAppId `in_` valList ids + -- where_ $ + -- service ^. SAppAppId `in_` valList ids Database.Esqueleto.Experimental.groupBy $ service ^. SAppAppId pure (service ^. SAppAppId, arrayAggDistinct (category ?. ServiceCategoryCategoryName)) let versionsQuery = select $ do @@ -462,7 +478,8 @@ fetchPackageMetadata ids = do $ table @SApp `innerJoin` table @SVersion `on` (\(service :& version) -> (service ^. SAppId) ==. version ^. SVersionAppId) - where_ $ service ^. SAppAppId `in_` valList ids + -- where_ $ + -- service ^. SAppAppId `in_` valList ids orderBy [desc (version ^. SVersionNumber)] Database.Esqueleto.Experimental.groupBy $ (service ^. SAppAppId, version ^. SVersionNumber) pure (service ^. SAppAppId, arrayAggDistinct (version ^. SVersionNumber)) diff --git a/src/Lib/External/AppMgr.hs b/src/Lib/External/AppMgr.hs index d7f74d7..97fc83d 100644 --- a/src/Lib/External/AppMgr.hs +++ b/src/Lib/External/AppMgr.hs @@ -31,7 +31,7 @@ readProcessWithExitCode' a b c = liftIO $ do (LBS.toStrict <$> getStdout process) (LBS.toStrict <$> getStderr process) -readProcessInheritStderr :: MonadIO m => String -> [String] -> ByteString -> m (ExitCode, ByteString) +readProcessInheritStderr :: MonadIO m => String -> [String] -> ByteString -> m (ExitCode, LBS.ByteString) readProcessInheritStderr a b c = liftIO $ do let pc = setStdin (byteStringInput $ LBS.fromStrict c) @@ -39,8 +39,7 @@ readProcessInheritStderr a b c = liftIO $ do $ setEnvInherit $ setStdout byteStringOutput $ System.Process.Typed.proc a b - withProcessWait pc - $ \process -> atomically $ liftA2 (,) (waitExitCodeSTM process) (LBS.toStrict <$> getStdout process) + withProcessWait pc $ \process -> atomically $ liftA2 (,) (waitExitCodeSTM process) (getStdout process) getConfig :: (MonadIO m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> S9ErrT m Text getConfig appmgrPath appPath e@(Extension appId) = fmap decodeUtf8 $ do @@ -48,38 +47,38 @@ getConfig appmgrPath appPath e@(Extension appId) = fmap decodeUtf8 $ do ["inspect", "config", appPath <> show e, "--json"] "" case ec of - ExitSuccess -> pure out + ExitSuccess -> pure $ LBS.toStrict out ExitFailure n -> throwE $ AppMgrE [i|info config #{appId} \--json|] n -getManifest :: (MonadIO m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> S9ErrT m ByteString +getManifest :: (MonadIO m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> S9ErrT m LBS.ByteString getManifest appmgrPath appPath e@(Extension appId) = do (ec, bs) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "manifest", appPath <> show e] "" case ec of ExitSuccess -> pure bs ExitFailure n -> throwE $ AppMgrE [i|embassy-sdk inspect manifest #{appId}|] n -getIcon :: (MonadIO m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> S9ErrT m ByteString +getIcon :: (MonadIO m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> S9ErrT m LBS.ByteString getIcon appmgrPath appPath (Extension icon) = do (ec, bs) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "icon", appPath] "" case ec of ExitSuccess -> pure bs ExitFailure n -> throwE $ AppMgrE [i|embassy-sdk inspect icon #{icon}|] n -getPackageHash :: (MonadIO m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> S9ErrT m ByteString +getPackageHash :: (MonadIO m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> S9ErrT m LBS.ByteString getPackageHash appmgrPath appPath e@(Extension appId) = do (ec, bs) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "hash", appPath <> show e] "" case ec of ExitSuccess -> pure bs ExitFailure n -> throwE $ AppMgrE [i|embassy-sdk inspect hash #{appId}|] n -getInstructions :: (MonadIO m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> S9ErrT m ByteString +getInstructions :: (MonadIO m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> S9ErrT m LBS.ByteString getInstructions appmgrPath appPath (Extension appId) = do (ec, bs) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "instructions", appPath] "" case ec of ExitSuccess -> pure bs ExitFailure n -> throwE $ AppMgrE [i|embassy-sdk inspect instructions #{appId}|] n -getLicense :: (MonadIO m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> S9ErrT m ByteString +getLicense :: (MonadIO m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> S9ErrT m LBS.ByteString getLicense appmgrPath appPath (Extension appId) = do (ec, bs) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "license", appPath] "" case ec of diff --git a/src/Lib/Types/AppIndex.hs b/src/Lib/Types/AppIndex.hs index 4ed9499..932d322 100644 --- a/src/Lib/Types/AppIndex.hs +++ b/src/Lib/Types/AppIndex.hs @@ -226,7 +226,7 @@ instance ToJSON ServiceManifest where ] -- >>> 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})]}) +-- 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})]}) testManifest :: BS.ByteString testManifest = [i|{ "id": "embassy-pages", diff --git a/src/Util/Shared.hs b/src/Util/Shared.hs index 03a2daa..582f53b 100644 --- a/src/Util/Shared.hs +++ b/src/Util/Shared.hs @@ -14,6 +14,7 @@ import Lib.Types.Emver import Data.Semigroup import Lib.External.AppMgr import Lib.Error +import qualified Data.ByteString.Lazy as BS getVersionFromQuery :: KnownSymbol a => FilePath -> Extension a -> Handler (Maybe Version) getVersionFromQuery rootDir ext = do @@ -38,4 +39,4 @@ getBestVersion rootDir ext spec = do addPackageHeader :: (MonadHandler m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> m () addPackageHeader appMgrDir appDir appExt = do packageHash <- handleS9ErrT $ getPackageHash appMgrDir appDir appExt - addHeader "X-S9PK-HASH" $ decodeUtf8 packageHash + addHeader "X-S9PK-HASH" $ decodeUtf8 $ BS.toStrict packageHash From d7f9c2879f419d9c26d312de11afbfd411be01cc Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Thu, 23 Sep 2021 14:53:23 -0600 Subject: [PATCH 05/48] adds timings --- src/Handler/Marketplace.hs | 171 +++++++++++++++++++++---------------- 1 file changed, 97 insertions(+), 74 deletions(-) diff --git a/src/Handler/Marketplace.hs b/src/Handler/Marketplace.hs index c5dc3ff..25a575d 100644 --- a/src/Handler/Marketplace.hs +++ b/src/Handler/Marketplace.hs @@ -11,39 +11,39 @@ {-# LANGUAGE DeriveAnyClass #-} module Handler.Marketplace where -import Startlude hiding ( from - , Handler +import Data.Aeson +import qualified Data.ByteString.Lazy as BS +import qualified Data.HashMap.Strict as HM +import Data.List +import qualified Data.List.NonEmpty as NE +import Data.Semigroup +import Data.String.Interpolate.IsString +import qualified Data.Text as T +import Database.Esqueleto.Experimental +import Database.Esqueleto.PostgreSQL ( arrayAggDistinct ) +import Database.Marketplace +import qualified Database.Persist as P +import Foundation +import Lib.Error +import Lib.External.AppMgr +import Lib.Registry +import Lib.Types.AppIndex +import Lib.Types.AppIndex ( ) +import Lib.Types.Category +import Lib.Types.Emver +import Model +import Network.HTTP.Types +import Settings +import Startlude hiding ( Handler + , from , on , sortOn ) -import Foundation -import Yesod.Core -import qualified Database.Persist as P -import Model -import Yesod.Persist.Core -import Database.Marketplace -import Data.List -import Lib.Types.Category -import Lib.Types.AppIndex -import qualified Data.HashMap.Strict as HM -import Lib.Types.Emver -import qualified Data.List.NonEmpty as NE -import Database.Esqueleto.Experimental -import Lib.Error -import Network.HTTP.Types -import Lib.Registry -import Settings import System.FilePath.Posix -import Lib.External.AppMgr -import Data.Aeson -import qualified Data.ByteString.Lazy as BS -import qualified Data.Text as T -import Data.String.Interpolate.IsString -import Util.Shared -import Lib.Types.AppIndex ( ) import UnliftIO.Async -import Database.Esqueleto.PostgreSQL ( arrayAggDistinct ) -import Data.Semigroup +import Util.Shared +import Yesod.Core +import Yesod.Persist.Core type URL = Text newtype CategoryRes = CategoryRes { @@ -55,15 +55,16 @@ instance ToContent CategoryRes where toContent = toContent . toJSON instance ToTypedContent CategoryRes where toTypedContent = toTypedContent . toJSON -data ServiceRes = ServiceRes - { serviceResIcon :: URL - , serviceResManifest :: Maybe Data.Aeson.Value -- ServiceManifest - , serviceResCategories :: [CategoryTitle] - , serviceResInstructions :: URL - , serviceResLicense :: URL - , serviceResVersions :: [Version] +data ServiceRes = ServiceRes + { serviceResIcon :: URL + , serviceResManifest :: Maybe Data.Aeson.Value -- ServiceManifest + , serviceResCategories :: [CategoryTitle] + , serviceResInstructions :: URL + , serviceResLicense :: URL + , serviceResVersions :: [Version] , serviceResDependencyInfo :: HM.HashMap AppIdentifier DependencyInfo - } deriving (Generic) + } + deriving Generic newtype ReleaseNotes = ReleaseNotes { unReleaseNotes :: HM.HashMap Version Text } deriving (Eq, Show) @@ -89,15 +90,17 @@ instance ToTypedContent ServiceRes where toTypedContent = toTypedContent . toJSON data DependencyInfo = DependencyInfo { dependencyInfoTitle :: AppIdentifier - , dependencyInfoIcon :: URL - } deriving (Eq, Show) + , dependencyInfoIcon :: URL + } + deriving (Eq, Show) instance ToJSON DependencyInfo where toJSON DependencyInfo {..} = object ["icon" .= dependencyInfoIcon, "title" .= dependencyInfoTitle] -data ServiceListRes = ServiceListRes { - serviceListResCategories :: [CategoryTitle] - , serviceListResServices :: [ServiceAvailable] -} deriving (Show) +data ServiceListRes = ServiceListRes + { serviceListResCategories :: [CategoryTitle] + , serviceListResServices :: [ServiceAvailable] + } + deriving Show instance ToJSON ServiceListRes where toJSON ServiceListRes {..} = object ["categories" .= serviceListResCategories, "services" .= serviceListResServices] @@ -107,12 +110,13 @@ instance ToTypedContent ServiceListRes where toTypedContent = toTypedContent . toJSON data ServiceAvailable = ServiceAvailable - { serviceAvailableId :: AppIdentifier - , serviceAvailableTitle :: Text - , serviceAvailableVersion :: Version - , serviceAvailableIcon :: URL + { serviceAvailableId :: AppIdentifier + , serviceAvailableTitle :: Text + , serviceAvailableVersion :: Version + , serviceAvailableIcon :: URL , serviceAvailableDescShort :: Text - } deriving (Show) + } + deriving Show instance ToJSON ServiceAvailable where toJSON ServiceAvailable {..} = object [ "id" .= serviceAvailableId @@ -144,18 +148,19 @@ instance ToTypedContent VersionLatestRes where data OrderArrangement = ASC | DESC deriving (Eq, Show, Read) data ServiceListDefaults = ServiceListDefaults - { serviceListOrder :: OrderArrangement - , serviceListPageLimit :: Int64 -- the number of items per page + { serviceListOrder :: OrderArrangement + , serviceListPageLimit :: Int64 -- the number of items per page , serviceListPageNumber :: Int64 -- the page you are on - , serviceListCategory :: Maybe CategoryTitle - , serviceListQuery :: Text + , serviceListCategory :: Maybe CategoryTitle + , serviceListQuery :: Text } deriving (Eq, Show, Read) data EosRes = EosRes - { eosResVersion :: Version - , eosResHeadline :: Text + { eosResVersion :: Version + , eosResHeadline :: Text , eosResReleaseNotes :: ReleaseNotes -} deriving (Eq, Show, Generic) + } + deriving (Eq, Show, Generic) instance ToJSON EosRes where toJSON EosRes {..} = object ["version" .= eosResVersion, "headline" .= eosResHeadline, "release-notes" .= eosResReleaseNotes] @@ -165,9 +170,10 @@ instance ToTypedContent EosRes where toTypedContent = toTypedContent . toJSON data PackageVersion = PackageVersion - { packageVersionId :: AppIdentifier + { packageVersionId :: AppIdentifier , packageVersionVersion :: VersionRange - } deriving (Show) + } + deriving Show instance FromJSON PackageVersion where parseJSON = withObject "package version" $ \o -> do packageVersionId <- o .: "id" @@ -207,8 +213,9 @@ getReleaseNotesR = do case lookup "id" getParameters of Nothing -> sendResponseStatus status400 ("expected query param \"id\" to exist" :: Text) Just package -> do - (service, _ ) <- runDB $ fetchLatestApp package >>= errOnNothing status404 "package not found" - (_ , mappedVersions) <- fetchAllAppVersions (entityKey service) + (service, _) <- runDB $ fetchLatestApp (AppIdentifier package) >>= errOnNothing status404 + "package not found" + (_, mappedVersions) <- fetchAllAppVersions (entityKey service) pure mappedVersions getVersionLatestR :: Handler VersionLatestRes @@ -225,15 +232,20 @@ getVersionLatestR = do $ VersionLatestRes $ HM.union ( HM.fromList - $ (\v -> - ( sAppAppId $ entityVal $ fst v :: AppIdentifier - , Just $ sVersionNumber $ entityVal $ snd v - ) - ) + $ (\v -> (sAppAppId $ entityVal $ fst v, Just $ sVersionNumber $ entityVal $ snd v)) <$> catMaybes found ) $ HM.fromList packageList +time :: MonadIO m => Text -> m a -> m a +time label m = do + start <- liftIO getCurrentTime + res <- m + end <- liftIO getCurrentTime + putStrLn $ label <> show (diffUTCTime end start) + pure res + + getPackageListR :: Handler ServiceAvailableRes getPackageListR = do getParameters <- reqGetParams <$> getRequest @@ -267,14 +279,19 @@ getPackageListR = do Just c -> case readMaybe $ toS c of Nothing -> sendResponseStatus status400 ("could not read per-page" :: Text) Just l -> pure l - query <- T.filter (not . isSpace) . fromMaybe (serviceListQuery defaults) <$> lookupGetParam "query" - filteredServices <- runDB $ searchServices category limit' ((page - 1) * limit') query + query <- time "filter" $ T.filter (not . isSpace) . fromMaybe (serviceListQuery defaults) <$> lookupGetParam + "query" + filteredServices <- time "search services" $ runDB $ searchServices category + limit' + ((page - 1) * limit') + query let filteredServices' = sAppAppId . entityVal <$> filteredServices settings <- getsYesod appSettings - packageMetadata <- runDB $ fetchPackageMetadata filteredServices' + packageMetadata <- time "metadata" $ runDB $ fetchPackageMetadata filteredServices' $logInfo $ show packageMetadata - serviceDetailResult <- liftIO - $ mapConcurrently (getServiceDetails settings packageMetadata Nothing) filteredServices' + serviceDetailResult <- time "service details" $ liftIO $ mapConcurrently + (getServiceDetails settings packageMetadata Nothing) + filteredServices' let (_, services) = partitionEithers serviceDetailResult pure $ ServiceAvailableRes services -- if null errors @@ -286,12 +303,15 @@ getPackageListR = do Right (packages :: [PackageVersion]) -> do -- for each item in list get best available from version range settings <- getsYesod appSettings - availableServicesResult <- liftIO $ mapConcurrently (getPackageDetails settings) packages + availableServicesResult <- time "availableServicesResult" $ liftIO $ mapConcurrently + (getPackageDetails settings) + packages -- @TODO fix _ error let (_, availableServices) = partitionEithers availableServicesResult - packageMetadata <- runDB $ fetchPackageMetadata (snd <$> availableServices) - serviceDetailResult <- liftIO - $ mapConcurrently (uncurry $ getServiceDetails settings packageMetadata) availableServices + packageMetadata <- time "metadata2" $ runDB $ fetchPackageMetadata (snd <$> availableServices) + serviceDetailResult <- time "service details 2" $ liftIO $ mapConcurrently + (uncurry $ getServiceDetails settings packageMetadata) + availableServices -- @TODO fix _ error let (_, services) = partitionEithers serviceDetailResult pure $ ServiceAvailableRes services @@ -304,6 +324,9 @@ getPackageListR = do + + + where getPackageDetails :: (MonadIO m) => AppSettings @@ -313,7 +336,7 @@ getPackageListR = do let appId = packageVersionId pv let spec = packageVersionVersion pv let appExt = Extension (show appId) :: Extension "s9pk" - getBestVersion (( "apps") . resourcesDir $ settings) appExt spec >>= \case + time "best version" $ getBestVersion (( "apps") . resourcesDir $ settings) appExt spec >>= \case Nothing -> pure $ Left @@ -442,7 +465,7 @@ fetchLatestApp appId = selectOne $ do pure (service, version) fetchLatestAppAtVersion :: MonadIO m - => Text + => AppIdentifier -> Version -> ReaderT SqlBackend m (Maybe (P.Entity SApp, P.Entity SVersion)) fetchLatestAppAtVersion appId version' = selectOne $ do From 4d797a9b2da1337d4c7c29de23ff5aeacaeb602d Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Thu, 23 Sep 2021 14:53:47 -0600 Subject: [PATCH 06/48] formatting --- src/Handler/Marketplace.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Handler/Marketplace.hs b/src/Handler/Marketplace.hs index 25a575d..4932522 100644 --- a/src/Handler/Marketplace.hs +++ b/src/Handler/Marketplace.hs @@ -242,7 +242,7 @@ time label m = do start <- liftIO getCurrentTime res <- m end <- liftIO getCurrentTime - putStrLn $ label <> show (diffUTCTime end start) + putStrLn $ label <> ": " <> show (diffUTCTime end start) pure res From b8e6ca990493363f4b1c5857c6b45a02df81bc05 Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Thu, 23 Sep 2021 15:11:26 -0600 Subject: [PATCH 07/48] time appmgr --- src/Handler/Marketplace.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Handler/Marketplace.hs b/src/Handler/Marketplace.hs index 4932522..193a893 100644 --- a/src/Handler/Marketplace.hs +++ b/src/Handler/Marketplace.hs @@ -368,7 +368,7 @@ getServiceDetails settings metadata maybeVersion appId = do Just v -> pure v let appDir = (<> "/") . ( show version) . ( show appId) $ appsDir let appExt = Extension (show appId) :: Extension "s9pk" - manifest' <- handleS9ErrNuclear $ getManifest appMgrDir appDir appExt + manifest' <- time "appmgr sucks" $ handleS9ErrNuclear $ getManifest appMgrDir appDir appExt case eitherDecode $ manifest' of Left e -> pure $ Left $ "Could not parse service manifest for " <> show appId <> ": " <> show e Right m -> do From 72355be67f75fb7651abf3aa3a7d3578c4491325 Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Thu, 23 Sep 2021 15:24:31 -0600 Subject: [PATCH 08/48] strictness annotations --- src/Lib/External/AppMgr.hs | 3 ++- src/Lib/Types/AppIndex.hs | 48 ++++++++++++++++++++------------------ 2 files changed, 27 insertions(+), 24 deletions(-) diff --git a/src/Lib/External/AppMgr.hs b/src/Lib/External/AppMgr.hs index 97fc83d..3ca9ec0 100644 --- a/src/Lib/External/AppMgr.hs +++ b/src/Lib/External/AppMgr.hs @@ -6,6 +6,7 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE BangPatterns #-} module Lib.External.AppMgr where @@ -52,7 +53,7 @@ getConfig appmgrPath appPath e@(Extension appId) = fmap decodeUtf8 $ do getManifest :: (MonadIO m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> S9ErrT m LBS.ByteString getManifest appmgrPath appPath e@(Extension appId) = do - (ec, bs) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "manifest", appPath <> show e] "" + (!ec, !bs) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "manifest", appPath <> show e] "" case ec of ExitSuccess -> pure bs ExitFailure n -> throwE $ AppMgrE [i|embassy-sdk inspect manifest #{appId}|] n diff --git a/src/Lib/Types/AppIndex.hs b/src/Lib/Types/AppIndex.hs index 932d322..9b42595 100644 --- a/src/Lib/Types/AppIndex.hs +++ b/src/Lib/Types/AppIndex.hs @@ -14,19 +14,19 @@ import Data.Aeson import qualified Data.HashMap.Strict as HM import qualified Data.List.NonEmpty as NE +import qualified Data.ByteString.Lazy as BS +import Data.Functor.Contravariant ( Contravariant(contramap) ) +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 Orphans.Emver ( ) import System.Directory -import Lib.Registry --- import Model -import qualified Data.Text as T -import Data.String.Interpolate.IsString -import qualified Data.ByteString.Lazy as BS -import Database.Persist.Postgresql import Yesod -import Data.Functor.Contravariant ( Contravariant(contramap) ) -import qualified GHC.Read ( Read(..) ) -import qualified GHC.Show ( Show(..) ) newtype AppIdentifier = AppIdentifier { unAppIdentifier :: Text } deriving (Eq) @@ -151,11 +151,12 @@ addFileTimestamp appDir ext service v = do pure $ Just service { storeAppTimestamp = Just time } data ServiceDependencyInfo = ServiceDependencyInfo - { serviceDependencyInfoOptional :: Maybe Text - , serviceDependencyInfoVersion :: VersionRange + { serviceDependencyInfoOptional :: Maybe Text + , serviceDependencyInfoVersion :: VersionRange , serviceDependencyInfoDescription :: Maybe Text - , serviceDependencyInfoCritical :: Bool - } deriving (Show) + , serviceDependencyInfoCritical :: Bool + } + deriving Show instance FromJSON ServiceDependencyInfo where parseJSON = withObject "service dependency info" $ \o -> do serviceDependencyInfoOptional <- o .:? "optional" @@ -185,16 +186,17 @@ instance FromJSON ServiceAlert where "stop" -> pure STOP _ -> fail "unknown service alert type" data ServiceManifest = ServiceManifest - { serviceManifestId :: AppIdentifier - , serviceManifestTitle :: Text - , serviceManifestVersion :: Version - , serviceManifestDescriptionLong :: Text - , serviceManifestDescriptionShort :: Text - , serviceManifestReleaseNotes :: Text - , serviceManifestIcon :: Maybe Text - , serviceManifestAlerts :: HM.HashMap ServiceAlert (Maybe Text) - , serviceManifestDependencies :: HM.HashMap AppIdentifier ServiceDependencyInfo - } deriving (Show) + { serviceManifestId :: !AppIdentifier + , serviceManifestTitle :: !Text + , serviceManifestVersion :: !Version + , serviceManifestDescriptionLong :: !Text + , serviceManifestDescriptionShort :: !Text + , serviceManifestReleaseNotes :: !Text + , serviceManifestIcon :: !(Maybe Text) + , serviceManifestAlerts :: !(HM.HashMap ServiceAlert (Maybe Text)) + , serviceManifestDependencies :: !(HM.HashMap AppIdentifier ServiceDependencyInfo) + } + deriving Show instance FromJSON ServiceManifest where parseJSON = withObject "service manifest" $ \o -> do serviceManifestId <- o .: "id" From 01d177274a443e6ab37a48418bb2daa046c6896f Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Thu, 23 Sep 2021 15:34:41 -0600 Subject: [PATCH 09/48] print appids when they complete --- src/Lib/External/AppMgr.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Lib/External/AppMgr.hs b/src/Lib/External/AppMgr.hs index 3ca9ec0..23755fd 100644 --- a/src/Lib/External/AppMgr.hs +++ b/src/Lib/External/AppMgr.hs @@ -54,6 +54,7 @@ getConfig appmgrPath appPath e@(Extension appId) = fmap decodeUtf8 $ do getManifest :: (MonadIO m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> S9ErrT m LBS.ByteString getManifest appmgrPath appPath e@(Extension appId) = do (!ec, !bs) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "manifest", appPath <> show e] "" + print appId case ec of ExitSuccess -> pure bs ExitFailure n -> throwE $ AppMgrE [i|embassy-sdk inspect manifest #{appId}|] n From 77b2dc09704a26717b5bac57797d0ae46d8c5b69 Mon Sep 17 00:00:00 2001 From: Lucy Cifferello <12953208+elvece@users.noreply.github.com> Date: Thu, 23 Sep 2021 14:51:18 -0600 Subject: [PATCH 10/48] update to not use fs read for versions, just previous db call metadata --- .gitignore | 6 +++++- config/settings.yml | 2 +- src/Handler/Marketplace.hs | 38 ++++++++++++++++---------------------- 3 files changed, 22 insertions(+), 24 deletions(-) diff --git a/.gitignore b/.gitignore index b7446d9..68e722a 100644 --- a/.gitignore +++ b/.gitignore @@ -31,4 +31,8 @@ version **/appmgr 0.3.0_features.md **/embassy-sdk -start9-registry.prof \ No newline at end of file +start9-registry.prof +start9-registry.hp +start9-registry.pdf +start9-registry.aux +start9-registry.ps \ No newline at end of file diff --git a/config/settings.yml b/config/settings.yml index c1106d7..d622f8b 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -13,7 +13,7 @@ ip-from-header: "_env:YESOD_IP_FROM_HEADER:false" # By default, `yesod devel` runs in development, and built executables use # production settings (see below). To override this, use the following: # -# development: false +development: true # Optional values with the following production defaults. # In development, they default to the inverse. diff --git a/src/Handler/Marketplace.hs b/src/Handler/Marketplace.hs index 193a893..ccd3743 100644 --- a/src/Handler/Marketplace.hs +++ b/src/Handler/Marketplace.hs @@ -287,7 +287,7 @@ getPackageListR = do query let filteredServices' = sAppAppId . entityVal <$> filteredServices settings <- getsYesod appSettings - packageMetadata <- time "metadata" $ runDB $ fetchPackageMetadata filteredServices' + packageMetadata <- time "metadata" $ runDB $ fetchPackageMetadata $ Just filteredServices' $logInfo $ show packageMetadata serviceDetailResult <- time "service details" $ liftIO $ mapConcurrently (getServiceDetails settings packageMetadata Nothing) @@ -303,12 +303,10 @@ getPackageListR = do Right (packages :: [PackageVersion]) -> do -- for each item in list get best available from version range settings <- getsYesod appSettings - availableServicesResult <- time "availableServicesResult" $ liftIO $ mapConcurrently - (getPackageDetails settings) - packages -- @TODO fix _ error + packageMetadata <- time "metadata2" $ runDB $ fetchPackageMetadata Nothing + availableServicesResult <- traverse (getPackageDetails packageMetadata) packages let (_, availableServices) = partitionEithers availableServicesResult - packageMetadata <- time "metadata2" $ runDB $ fetchPackageMetadata (snd <$> availableServices) serviceDetailResult <- time "service details 2" $ liftIO $ mapConcurrently (uncurry $ getServiceDetails settings packageMetadata) availableServices @@ -328,22 +326,18 @@ getPackageListR = do where - getPackageDetails :: (MonadIO m) - => AppSettings - -> PackageVersion - -> m (Either Text ((Maybe Version), AppIdentifier)) - getPackageDetails settings pv = do - let appId = packageVersionId pv - let spec = packageVersionVersion pv - let appExt = Extension (show appId) :: Extension "s9pk" - time "best version" $ getBestVersion (( "apps") . resourcesDir $ settings) appExt spec >>= \case - Nothing -> - pure - $ Left - $ "best version could not be found for " - <> show appId - <> " with spec " - <> show spec + getPackageDetails :: MonadIO m => (HM.HashMap AppIdentifier ([Version], [CategoryTitle])) -> PackageVersion -> m (Either Text ((Maybe Version), AppIdentifier)) + 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 $ "best version could not be found for " <> show appId <> " with spec " <> show spec Just v -> do pure $ Right (Just v, appId) @@ -478,7 +472,7 @@ fetchLatestAppAtVersion appId version' = selectOne $ do pure (service, version) fetchPackageMetadata :: MonadUnliftIO m - => [AppIdentifier] + => Maybe [AppIdentifier] -> ReaderT SqlBackend m (HM.HashMap AppIdentifier ([Version], [CategoryTitle])) fetchPackageMetadata ids = do let categoriesQuery = select $ do From 9fb5fe35e7ab3cc7ec5e1e9fc2158af5450e6cce Mon Sep 17 00:00:00 2001 From: Lucy Cifferello <12953208+elvece@users.noreply.github.com> Date: Thu, 23 Sep 2021 18:13:53 -0600 Subject: [PATCH 11/48] revert dev settings and incorrect fix --- config/settings.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/config/settings.yml b/config/settings.yml index d622f8b..c1106d7 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -13,7 +13,7 @@ ip-from-header: "_env:YESOD_IP_FROM_HEADER:false" # By default, `yesod devel` runs in development, and built executables use # production settings (see below). To override this, use the following: # -development: true +# development: false # Optional values with the following production defaults. # In development, they default to the inverse. From 38016eb04bdcbc91f2083b8db134df351e1a68aa Mon Sep 17 00:00:00 2001 From: Lucy Cifferello <12953208+elvece@users.noreply.github.com> Date: Thu, 23 Sep 2021 19:40:39 -0600 Subject: [PATCH 12/48] synchronize with 0.3.0 branch --- src/Database/Marketplace.hs | 1 - src/Handler/Icons.hs | 4 +-- src/Handler/Marketplace.hs | 51 ++++++++++++++++++++++++------------- src/Lib/Types/Category.hs | 34 ++++--------------------- 4 files changed, 41 insertions(+), 49 deletions(-) diff --git a/src/Database/Marketplace.hs b/src/Database/Marketplace.hs index 67bedbb..6660dd6 100644 --- a/src/Database/Marketplace.hs +++ b/src/Database/Marketplace.hs @@ -23,7 +23,6 @@ searchServices Nothing pageItems offset' query = select $ do ( (service ^. SAppDescShort `ilike` (%) ++. val query ++. (%)) ||. (service ^. SAppDescLong `ilike` (%) ++. val query ++. (%)) ||. (service ^. SAppTitle `ilike` (%) ++. val query ++. (%)) - ||. (service ^. SAppAppId `ilike` (%) ++. val query ++. (%)) ) orderBy [desc (service ^. SAppUpdatedAt)] limit pageItems diff --git a/src/Handler/Icons.hs b/src/Handler/Icons.hs index 030ba8b..138e8cf 100644 --- a/src/Handler/Icons.hs +++ b/src/Handler/Icons.hs @@ -39,7 +39,7 @@ getIconsR appId = do spec <- getVersionFromQuery appsDir ext >>= \case Nothing -> sendResponseStatus status404 ("Specified App Version Not Found" :: Text) Just v -> pure v - let appDir = (<> "/") . ( show spec) . ( toS appId) $ appsDir + let appDir = (<> "/") . ( show spec) . ( show appId) $ appsDir manifest' <- handleS9ErrT $ getManifest appMgrDir appDir ext manifest <- case eitherDecode manifest' of Left e -> do @@ -65,7 +65,7 @@ getIconsR appId = do -- (_, Just hout, _, _) <- liftIO (createProcess $ iconBs { std_out = CreatePipe }) -- respondSource typePlain (runConduit $ yieldMany () [iconBs]) -- respondSource typePlain $ sourceHandle hout .| awaitForever sendChunkBS - where ext = Extension (toS appId) :: Extension "s9pk" + where ext = Extension (show appId) :: Extension "s9pk" getLicenseR :: AppIdentifier -> Handler TypedContent getLicenseR appId = do diff --git a/src/Handler/Marketplace.hs b/src/Handler/Marketplace.hs index ccd3743..8b90a2a 100644 --- a/src/Handler/Marketplace.hs +++ b/src/Handler/Marketplace.hs @@ -41,7 +41,6 @@ import Startlude hiding ( Handler ) import System.FilePath.Posix import UnliftIO.Async -import Util.Shared import Yesod.Core import Yesod.Persist.Core @@ -287,7 +286,7 @@ getPackageListR = do query let filteredServices' = sAppAppId . entityVal <$> filteredServices settings <- getsYesod appSettings - packageMetadata <- time "metadata" $ runDB $ fetchPackageMetadata $ Just filteredServices' + packageMetadata <- time "metadata" $ runDB $ fetchPackageMetadata $logInfo $ show packageMetadata serviceDetailResult <- time "service details" $ liftIO $ mapConcurrently (getServiceDetails settings packageMetadata Nothing) @@ -304,7 +303,7 @@ getPackageListR = do -- for each item in list get best available from version range settings <- getsYesod appSettings -- @TODO fix _ error - packageMetadata <- time "metadata2" $ runDB $ fetchPackageMetadata Nothing + packageMetadata <- time "metadata2" $ runDB $ fetchPackageMetadata availableServicesResult <- traverse (getPackageDetails packageMetadata) packages let (_, availableServices) = partitionEithers availableServicesResult serviceDetailResult <- time "service details 2" $ liftIO $ mapConcurrently @@ -319,6 +318,21 @@ getPackageListR = do + + + + + + + + + + + + + + + @@ -326,18 +340,27 @@ getPackageListR = do where - getPackageDetails :: MonadIO m => (HM.HashMap AppIdentifier ([Version], [CategoryTitle])) -> PackageVersion -> m (Either Text ((Maybe Version), AppIdentifier)) + getPackageDetails :: MonadIO m + => (HM.HashMap AppIdentifier ([Version], [CategoryTitle])) + -> PackageVersion + -> m (Either Text ((Maybe Version), AppIdentifier)) getPackageDetails metadata pv = do let appId = packageVersionId pv - let spec = packageVersionVersion 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 + 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 + let best = getMax <$> foldMap (Just . Max) satisfactory case best of - Nothing -> pure $ Left $ "best version could not be found for " <> show appId <> " with spec " <> show spec + Nothing -> + pure + $ Left + $ "best version could not be found for " + <> show appId + <> " with spec " + <> show spec Just v -> do pure $ Right (Just v, appId) @@ -471,10 +494,8 @@ fetchLatestAppAtVersion appId version' = selectOne $ do where_ $ (service ^. SAppAppId ==. val appId) &&. (version ^. SVersionNumber ==. val version') pure (service, version) -fetchPackageMetadata :: MonadUnliftIO m - => Maybe [AppIdentifier] - -> ReaderT SqlBackend m (HM.HashMap AppIdentifier ([Version], [CategoryTitle])) -fetchPackageMetadata ids = do +fetchPackageMetadata :: MonadUnliftIO m => ReaderT SqlBackend m (HM.HashMap AppIdentifier ([Version], [CategoryTitle])) +fetchPackageMetadata = do let categoriesQuery = select $ do (service :& category) <- from @@ -485,8 +506,6 @@ fetchPackageMetadata ids = do ==. category ?. ServiceCategoryServiceId ) - -- where_ $ - -- service ^. SAppAppId `in_` valList ids Database.Esqueleto.Experimental.groupBy $ service ^. SAppAppId pure (service ^. SAppAppId, arrayAggDistinct (category ?. ServiceCategoryCategoryName)) let versionsQuery = select $ do @@ -495,8 +514,6 @@ fetchPackageMetadata ids = do $ table @SApp `innerJoin` table @SVersion `on` (\(service :& version) -> (service ^. SAppId) ==. version ^. SVersionAppId) - -- where_ $ - -- service ^. SAppAppId `in_` valList ids orderBy [desc (version ^. SVersionNumber)] Database.Esqueleto.Experimental.groupBy $ (service ^. SAppAppId, version ^. SVersionNumber) pure (service ^. SAppAppId, arrayAggDistinct (version ^. SVersionNumber)) diff --git a/src/Lib/Types/Category.hs b/src/Lib/Types/Category.hs index 13f9b47..d302ae9 100644 --- a/src/Lib/Types/Category.hs +++ b/src/Lib/Types/Category.hs @@ -3,11 +3,11 @@ module Lib.Types.Category where -import Startlude -import Database.Persist.Postgresql -import Data.Aeson -import Control.Monad -import Yesod.Core +import Startlude +import Database.Persist.Postgresql +import Data.Aeson +import Control.Monad +import Yesod.Core data CategoryTitle = FEATURED | BITCOIN @@ -45,28 +45,4 @@ instance FromJSON CategoryTitle where instance ToContent CategoryTitle where toContent = toContent . toJSON instance ToTypedContent CategoryTitle where -<<<<<<< HEAD toTypedContent = toTypedContent . toJSON -<<<<<<< HEAD -======= -instance FromField CategoryTitle where - fromField a = fromJSONField a -instance FromField [CategoryTitle] where - fromField a = fromJSONField a -instance ToField [CategoryTitle] where - toField a = toJSONField a - -parseCT :: Text -> CategoryTitle -parseCT = \case - "featured" -> FEATURED - "bitcoin" -> BITCOIN - "lightning" -> LIGHTNING - "data" -> DATA - "messaging" -> MESSAGING - "social" -> SOCIAL - "alt coin" -> ALTCOIN - -- _ -> fail "unknown category title" ->>>>>>> aggregate query functions -======= - toTypedContent = toTypedContent . toJSON ->>>>>>> clean up From beaace0238938f0e2a0611c81b26b519a40b0ea9 Mon Sep 17 00:00:00 2001 From: Lucy Cifferello <12953208+elvece@users.noreply.github.com> Date: Thu, 23 Sep 2021 19:44:19 -0600 Subject: [PATCH 13/48] formatting --- src/Handler/Marketplace.hs | 21 --------------------- 1 file changed, 21 deletions(-) diff --git a/src/Handler/Marketplace.hs b/src/Handler/Marketplace.hs index 8b90a2a..195d685 100644 --- a/src/Handler/Marketplace.hs +++ b/src/Handler/Marketplace.hs @@ -318,27 +318,6 @@ getPackageListR = do - - - - - - - - - - - - - - - - - - - - - where getPackageDetails :: MonadIO m => (HM.HashMap AppIdentifier ([Version], [CategoryTitle])) From 7e70ffe3f31fd881f2ab3bf6d706f864efa7a864 Mon Sep 17 00:00:00 2001 From: Lucy Cifferello <12953208+elvece@users.noreply.github.com> Date: Fri, 24 Sep 2021 13:30:14 -0600 Subject: [PATCH 14/48] fix bug wto show multiple versions in metadata --- src/Application.hs | 8 ++++- src/Handler/Marketplace.hs | 66 ++++++++++++++++++++++++++++++++++++-- src/Lib/Types/Category.hs | 4 ++- 3 files changed, 74 insertions(+), 4 deletions(-) diff --git a/src/Application.hs b/src/Application.hs index 5a19bbd..d79ce17 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -24,7 +24,7 @@ module Application , getAppSettings -- * for GHCI , handler - ) where + ,db) where import Startlude hiding (Handler) @@ -67,6 +67,8 @@ import Network.HTTP.Types.Header ( hOrigin ) import Data.List (lookup) import Network.Wai.Middleware.RequestLogger.JSON import System.Directory (createDirectoryIfMissing) +import Database.Persist.Sql (SqlBackend) +import Yesod -- This line actually creates our YesodDispatch instance. It is the second half -- of the call to mkYesodData which occurs in Foundation.hs. Please see the @@ -342,3 +344,7 @@ develMain = do -- | Run a handler handler :: Handler a -> IO a handler h = getAppSettings >>= makeFoundation >>= flip unsafeHandler h + +-- | Run DB queries +db :: ReaderT SqlBackend (HandlerFor RegistryCtx) a -> IO a +db = handler . runDB \ No newline at end of file diff --git a/src/Handler/Marketplace.hs b/src/Handler/Marketplace.hs index 195d685..dd8833a 100644 --- a/src/Handler/Marketplace.hs +++ b/src/Handler/Marketplace.hs @@ -318,6 +318,66 @@ getPackageListR = do + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + where getPackageDetails :: MonadIO m => (HM.HashMap AppIdentifier ([Version], [CategoryTitle])) @@ -473,7 +533,8 @@ fetchLatestAppAtVersion appId version' = selectOne $ do where_ $ (service ^. SAppAppId ==. val appId) &&. (version ^. SVersionNumber ==. val version') pure (service, version) -fetchPackageMetadata :: MonadUnliftIO m => ReaderT SqlBackend m (HM.HashMap AppIdentifier ([Version], [CategoryTitle])) +fetchPackageMetadata :: (MonadLogger m, MonadUnliftIO m) + => ReaderT SqlBackend m (HM.HashMap AppIdentifier ([Version], [CategoryTitle])) fetchPackageMetadata = do let categoriesQuery = select $ do (service :& category) <- @@ -501,7 +562,8 @@ fetchPackageMetadata = do c = foreach categories $ \(appId, categories') -> (unValue appId, catMaybes $ fromMaybe [] (unValue categories')) let v = foreach versions $ \(appId, versions') -> (unValue appId, fromMaybe [] (unValue versions')) - pure $ HM.intersectionWith (\vers cts -> (vers, cts)) (HM.fromList v) (HM.fromList c) + let vv = HM.fromListWithKey (\_ vers vers' -> (++) vers vers') v + pure $ HM.intersectionWith (\vers cts -> (cts, vers)) (HM.fromList c) vv fetchAppCategories :: MonadIO m => Key SApp -> ReaderT SqlBackend m [P.Entity ServiceCategory] fetchAppCategories appId = select $ do diff --git a/src/Lib/Types/Category.hs b/src/Lib/Types/Category.hs index d302ae9..20aede7 100644 --- a/src/Lib/Types/Category.hs +++ b/src/Lib/Types/Category.hs @@ -1,5 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE DeriveGeneric #-} module Lib.Types.Category where @@ -16,7 +17,7 @@ data CategoryTitle = FEATURED | MESSAGING | SOCIAL | ALTCOIN - deriving (Eq, Enum, Show, Read) + deriving (Eq, Enum, Show, Read, Generic) instance PersistField CategoryTitle where fromPersistValue = fromPersistValueJSON toPersistValue = toPersistValueJSON @@ -46,3 +47,4 @@ instance ToContent CategoryTitle where toContent = toContent . toJSON instance ToTypedContent CategoryTitle where toTypedContent = toTypedContent . toJSON +instance Hashable CategoryTitle From 5c03c0e3055fd6fa52026694b91426ced94a2856 Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Fri, 24 Sep 2021 14:15:07 -0600 Subject: [PATCH 15/48] clean up instrumentation --- src/Handler/Marketplace.hs | 37 +++++++++++-------------------------- src/Lib/External/AppMgr.hs | 1 - 2 files changed, 11 insertions(+), 27 deletions(-) diff --git a/src/Handler/Marketplace.hs b/src/Handler/Marketplace.hs index dd8833a..e920565 100644 --- a/src/Handler/Marketplace.hs +++ b/src/Handler/Marketplace.hs @@ -236,15 +236,6 @@ getVersionLatestR = do ) $ HM.fromList packageList -time :: MonadIO m => Text -> m a -> m a -time label m = do - start <- liftIO getCurrentTime - res <- m - end <- liftIO getCurrentTime - putStrLn $ label <> ": " <> show (diffUTCTime end start) - pure res - - getPackageListR :: Handler ServiceAvailableRes getPackageListR = do getParameters <- reqGetParams <$> getRequest @@ -278,19 +269,14 @@ getPackageListR = do Just c -> case readMaybe $ toS c of Nothing -> sendResponseStatus status400 ("could not read per-page" :: Text) Just l -> pure l - query <- time "filter" $ T.filter (not . isSpace) . fromMaybe (serviceListQuery defaults) <$> lookupGetParam - "query" - filteredServices <- time "search services" $ runDB $ searchServices category - limit' - ((page - 1) * limit') - query + query <- T.filter (not . isSpace) . fromMaybe (serviceListQuery defaults) <$> lookupGetParam "query" + filteredServices <- runDB $ searchServices category limit' ((page - 1) * limit') query let filteredServices' = sAppAppId . entityVal <$> filteredServices settings <- getsYesod appSettings - packageMetadata <- time "metadata" $ runDB $ fetchPackageMetadata + packageMetadata <- runDB $ fetchPackageMetadata $logInfo $ show packageMetadata - serviceDetailResult <- time "service details" $ liftIO $ mapConcurrently - (getServiceDetails settings packageMetadata Nothing) - filteredServices' + serviceDetailResult <- liftIO + $ mapConcurrently (getServiceDetails settings packageMetadata Nothing) filteredServices' let (_, services) = partitionEithers serviceDetailResult pure $ ServiceAvailableRes services -- if null errors @@ -303,12 +289,11 @@ getPackageListR = do -- for each item in list get best available from version range settings <- getsYesod appSettings -- @TODO fix _ error - packageMetadata <- time "metadata2" $ runDB $ fetchPackageMetadata + packageMetadata <- runDB $ fetchPackageMetadata availableServicesResult <- traverse (getPackageDetails packageMetadata) packages let (_, availableServices) = partitionEithers availableServicesResult - serviceDetailResult <- time "service details 2" $ liftIO $ mapConcurrently - (uncurry $ getServiceDetails settings packageMetadata) - availableServices + serviceDetailResult <- liftIO + $ mapConcurrently (uncurry $ getServiceDetails settings packageMetadata) availableServices -- @TODO fix _ error let (_, services) = partitionEithers serviceDetailResult pure $ ServiceAvailableRes services @@ -424,12 +409,12 @@ getServiceDetails settings metadata maybeVersion appId = do Just v -> pure v let appDir = (<> "/") . ( show version) . ( show appId) $ appsDir let appExt = Extension (show appId) :: Extension "s9pk" - manifest' <- time "appmgr sucks" $ handleS9ErrNuclear $ getManifest appMgrDir appDir appExt + manifest' <- handleS9ErrNuclear $ getManifest appMgrDir appDir appExt case eitherDecode $ manifest' of Left e -> pure $ Left $ "Could not parse service manifest for " <> show appId <> ": " <> show e Right m -> do - d <- liftIO - $ mapConcurrently (mapDependencyMetadata domain metadata) (HM.toList $ serviceManifestDependencies m) + d <- liftIO $ mapConcurrently (mapDependencyMetadata domain metadata) + (HM.toList $ serviceManifestDependencies m) pure $ Right $ ServiceRes { serviceResIcon = [i|https://#{domain}/package/icon/#{appId}|] , serviceResManifest = decode $ manifest' -- pass through raw JSON Value , serviceResCategories = snd packageMetadata diff --git a/src/Lib/External/AppMgr.hs b/src/Lib/External/AppMgr.hs index 23755fd..3ca9ec0 100644 --- a/src/Lib/External/AppMgr.hs +++ b/src/Lib/External/AppMgr.hs @@ -54,7 +54,6 @@ getConfig appmgrPath appPath e@(Extension appId) = fmap decodeUtf8 $ do getManifest :: (MonadIO m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> S9ErrT m LBS.ByteString getManifest appmgrPath appPath e@(Extension appId) = do (!ec, !bs) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "manifest", appPath <> show e] "" - print appId case ec of ExitSuccess -> pure bs ExitFailure n -> throwE $ AppMgrE [i|embassy-sdk inspect manifest #{appId}|] n From caf8e8ab9a1b4cdd5f3133f32ef8baba8ebb73dd Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Mon, 27 Sep 2021 10:07:00 -0600 Subject: [PATCH 16/48] changes appmgr calls to be conduit sources. --- src/Handler/Apps.hs | 16 ++--- src/Handler/Icons.hs | 25 +++++--- src/Handler/Marketplace.hs | 45 ++++++++------ src/Lib/Error.hs | 4 +- src/Lib/External/AppMgr.hs | 117 ++++++++++++++++++++++++------------- src/Settings.hs | 1 - src/Util/Shared.hs | 12 ++-- 7 files changed, 135 insertions(+), 85 deletions(-) diff --git a/src/Handler/Apps.hs b/src/Handler/Apps.hs index bbbc9bb..b901df7 100644 --- a/src/Handler/Apps.hs +++ b/src/Handler/Apps.hs @@ -31,16 +31,16 @@ import System.Posix.Files ( fileSize import Yesod.Core import Yesod.Persist.Core +import Database.Queries import Foundation +import Lib.Error +import Lib.External.AppMgr import Lib.Registry import Lib.Types.AppIndex import Lib.Types.Emver import Lib.Types.FileSystem -import Lib.Error -import Lib.External.AppMgr -import Settings -import Database.Queries import Network.Wai ( Request(requestHeaderUserAgent) ) +import Settings import Util.Shared pureLog :: Show a => a -> Handler a @@ -78,9 +78,11 @@ getAppManifestR appId = do Nothing -> sendResponseStatus status404 ("Specified App Version Not Found" :: Text) Just v -> pure v let appDir = (<> "/") . ( show av) . ( show appId) $ appsDir - manifest <- handleS9ErrT $ getManifest appMgrDir appDir appExt addPackageHeader appMgrDir appDir appExt - pure $ TypedContent "application/json" (toContent manifest) + getManifest appMgrDir + appDir + appExt + (\bsSource -> respondSource "application/json" (bsSource .| awaitForever sendChunkBS)) where appExt = Extension (show appId) :: Extension "s9pk" getAppConfigR :: AppIdentifier -> Handler TypedContent @@ -92,8 +94,8 @@ getAppConfigR appId = do Nothing -> sendResponseStatus status404 ("Specified App Version Not Found" :: Text) Just v -> pure v let appDir = (<> "/") . ( show av) . ( show appId) $ appsDir - config <- handleS9ErrT $ getConfig appMgrDir appDir appExt addPackageHeader appMgrDir appDir appExt + config <- getConfig appMgrDir appDir appExt (\bsSource -> _) pure $ TypedContent "application/json" (toContent config) where appExt = Extension (show appId) :: Extension "s9pk" diff --git a/src/Handler/Icons.hs b/src/Handler/Icons.hs index 138e8cf..056c58e 100644 --- a/src/Handler/Icons.hs +++ b/src/Handler/Icons.hs @@ -13,6 +13,11 @@ import Yesod.Core import Data.Aeson import qualified Data.ByteString.Lazy as BS +import Data.Conduit ( (.|) + , awaitForever + , runConduit + ) +import qualified Data.Conduit.List as CL import Foundation import Lib.Error import Lib.External.AppMgr @@ -40,7 +45,7 @@ getIconsR appId = do Nothing -> sendResponseStatus status404 ("Specified App Version Not Found" :: Text) Just v -> pure v let appDir = (<> "/") . ( show spec) . ( show appId) $ appsDir - manifest' <- handleS9ErrT $ getManifest appMgrDir appDir ext + manifest' <- getManifest appMgrDir appDir ext (\bsSource -> runConduit $ bsSource .| CL.foldMap BS.fromStrict) manifest <- case eitherDecode manifest' of Left e -> do $logError "could not parse service manifest!" @@ -61,10 +66,10 @@ getIconsR appId = do SVG -> pure typeSvg JPG -> pure typeJpeg JPEG -> pure typeJpeg - respondSource mimeType (sendChunkBS =<< BS.toStrict <$> handleS9ErrT (getIcon appMgrDir (appDir show ext) ext)) - -- (_, Just hout, _, _) <- liftIO (createProcess $ iconBs { std_out = CreatePipe }) - -- respondSource typePlain (runConduit $ yieldMany () [iconBs]) - -- respondSource typePlain $ sourceHandle hout .| awaitForever sendChunkBS + getIcon appMgrDir + (appDir show ext) + ext + (\bsSource -> respondSource mimeType (bsSource .| awaitForever sendChunkBS)) where ext = Extension (show appId) :: Extension "s9pk" getLicenseR :: AppIdentifier -> Handler TypedContent @@ -76,8 +81,8 @@ getLicenseR appId = do servicePath <- liftIO $ getVersionedFileFromDir appsDir ext spec case servicePath of Nothing -> notFound - Just p -> do - respondSource typePlain (sendChunkBS =<< BS.toStrict <$> handleS9ErrT (getLicense appMgrDir p ext)) + Just p -> + getLicense appMgrDir p ext (\bsSource -> respondSource typePlain (bsSource .| awaitForever sendChunkBS)) where ext = Extension (show appId) :: Extension "s9pk" getInstructionsR :: AppIdentifier -> Handler TypedContent @@ -89,6 +94,8 @@ getInstructionsR appId = do servicePath <- liftIO $ getVersionedFileFromDir appsDir ext spec case servicePath of Nothing -> notFound - Just p -> do - respondSource typePlain (sendChunkBS =<< BS.toStrict <$> handleS9ErrT (getInstructions appMgrDir p ext)) + Just p -> getInstructions appMgrDir + p + ext + (\bsSource -> respondSource typePlain (bsSource .| awaitForever sendChunkBS)) where ext = Extension (show appId) :: Extension "s9pk" diff --git a/src/Handler/Marketplace.hs b/src/Handler/Marketplace.hs index e920565..61567e2 100644 --- a/src/Handler/Marketplace.hs +++ b/src/Handler/Marketplace.hs @@ -11,8 +11,13 @@ {-# LANGUAGE DeriveAnyClass #-} module Handler.Marketplace where +import Conduit ( (.|) + , MonadThrow + , mapC + ) import Data.Aeson import qualified Data.ByteString.Lazy as BS +import qualified Data.Conduit.Text as CT import qualified Data.HashMap.Strict as HM import Data.List import qualified Data.List.NonEmpty as NE @@ -388,7 +393,7 @@ getPackageListR = do Just v -> do pure $ Right (Just v, appId) -getServiceDetails :: (MonadIO m, Monad m, MonadError IOException m) +getServiceDetails :: (MonadUnliftIO m, Monad m, MonadError IOException m) => AppSettings -> (HM.HashMap AppIdentifier ([Version], [CategoryTitle])) -> Maybe Version @@ -409,7 +414,7 @@ getServiceDetails settings metadata maybeVersion appId = do Just v -> pure v let appDir = (<> "/") . ( show version) . ( show appId) $ appsDir let appExt = Extension (show appId) :: Extension "s9pk" - manifest' <- handleS9ErrNuclear $ getManifest appMgrDir appDir appExt + manifest' <- getManifest appMgrDir appDir appExt (\bs -> sinkMem (bs .| mapC BS.fromStrict)) case eitherDecode $ manifest' of Left e -> pure $ Left $ "Could not parse service manifest for " <> show appId <> ": " <> show e Right m -> do @@ -447,24 +452,30 @@ mapDependencyMetadata domain metadata (appId, depInfo) = do } ) -decodeIcon :: (MonadHandler m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> m URL -decodeIcon appmgrPath depPath e@(Extension icon) = do - icon' <- handleS9ErrT $ getIcon appmgrPath depPath e - case eitherDecode icon' of - Left e' -> do - $logInfo $ T.pack e' - sendResponseStatus status400 e' - Right (i' :: URL) -> pure $ i' <> T.pack icon +-- decodeIcon :: (MonadHandler m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> m URL +-- decodeIcon appmgrPath depPath e@(Extension icon) = do +-- icon' <- handleS9ErrT $ getIcon appmgrPath depPath e +-- case eitherDecode icon' of +-- Left e' -> do +-- $logInfo $ T.pack e' +-- sendResponseStatus status400 e' +-- Right (i' :: URL) -> pure $ i' <> T.pack icon -decodeInstructions :: (MonadHandler m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> m Text +decodeInstructions :: (MonadUnliftIO m, MonadHandler m, KnownSymbol a, MonadThrow m) + => FilePath + -> FilePath + -> Extension a + -> m Text decodeInstructions appmgrPath depPath package = do - instructions <- handleS9ErrT $ getInstructions appmgrPath depPath package - pure $ decodeUtf8 $ BS.toStrict instructions + getInstructions appmgrPath depPath package (\bs -> sinkMem (bs .| CT.decode CT.utf8)) -decodeLicense :: (MonadHandler m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> m Text -decodeLicense appmgrPath depPath package = do - license <- handleS9ErrT $ getLicense appmgrPath depPath package - pure $ decodeUtf8 $ BS.toStrict license +decodeLicense :: (MonadUnliftIO m, MonadThrow m, MonadHandler m, KnownSymbol a) + => FilePath + -> FilePath + -> Extension a + -> m Text +decodeLicense appmgrPath depPath package = + getLicense appmgrPath depPath package (\bs -> sinkMem (bs .| CT.decode CT.utf8)) fetchAllAppVersions :: Key SApp -> HandlerFor RegistryCtx ([VersionInfo], ReleaseNotes) fetchAllAppVersions appId = do diff --git a/src/Lib/Error.hs b/src/Lib/Error.hs index e9a01e7..f743558 100644 --- a/src/Lib/Error.hs +++ b/src/Lib/Error.hs @@ -5,15 +5,15 @@ module Lib.Error where import Startlude +import Data.String.Interpolate.IsString import Network.HTTP.Types import Yesod.Core -import Data.String.Interpolate.IsString type S9ErrT m = ExceptT S9Error m data S9Error = PersistentE Text - | AppMgrE Text Int + | AppMgrE Text ExitCode | NotFoundE Text deriving (Show, Eq) diff --git a/src/Lib/External/AppMgr.hs b/src/Lib/External/AppMgr.hs index 3ca9ec0..56628e8 100644 --- a/src/Lib/External/AppMgr.hs +++ b/src/Lib/External/AppMgr.hs @@ -10,14 +10,25 @@ module Lib.External.AppMgr where -import Startlude +import Startlude hiding ( catch ) import qualified Data.ByteString.Lazy as LBS import Data.String.Interpolate.IsString import System.Process.Typed hiding ( createPipe ) +import Conduit ( (.|) + , ConduitT + , MonadThrow + , runConduit + ) +import qualified Data.Conduit.List as CL +import Data.Conduit.Process.Typed import Lib.Error import Lib.Registry +import System.FilePath ( () ) +import UnliftIO ( MonadUnliftIO + , catch + ) readProcessWithExitCode' :: MonadIO m => String -> [String] -> ByteString -> m (ExitCode, ByteString, ByteString) readProcessWithExitCode' a b c = liftIO $ do @@ -32,56 +43,78 @@ readProcessWithExitCode' a b c = liftIO $ do (LBS.toStrict <$> getStdout process) (LBS.toStrict <$> getStderr process) -readProcessInheritStderr :: MonadIO m => String -> [String] -> ByteString -> m (ExitCode, LBS.ByteString) -readProcessInheritStderr a b c = liftIO $ do +readProcessInheritStderr :: MonadUnliftIO m + => String + -> [String] + -> ByteString + -> (ConduitT () ByteString m () -> m a) -- this is because we can't clean up the process in the unCPS'ed version of this + -> m a +readProcessInheritStderr a b c sink = do let pc = setStdin (byteStringInput $ LBS.fromStrict c) - $ setStderr inherit $ setEnvInherit - $ setStdout byteStringOutput + $ setStdout createSource $ System.Process.Typed.proc a b - withProcessWait pc $ \process -> atomically $ liftA2 (,) (waitExitCodeSTM process) (getStdout process) + withProcessTerm_ pc $ \p -> sink (getStdout p) -getConfig :: (MonadIO m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> S9ErrT m Text -getConfig appmgrPath appPath e@(Extension appId) = fmap decodeUtf8 $ do - (ec, out) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk") - ["inspect", "config", appPath <> show e, "--json"] +getConfig :: (MonadUnliftIO m, MonadThrow m, KnownSymbol a) + => FilePath + -> FilePath + -> Extension a + -> (ConduitT () ByteString m () -> m r) + -> m r +getConfig appmgrPath appPath e@(Extension appId) sink = do + let + appmgr = readProcessInheritStderr (appmgrPath <> "embassy-sdk") + ["inspect", "config", appPath show e, "--json"] "" - case ec of - ExitSuccess -> pure $ LBS.toStrict out - ExitFailure n -> throwE $ AppMgrE [i|info config #{appId} \--json|] n + appmgr sink `catch` \ece -> throwIO (AppMgrE [i|inspect config #{appId} \--json|] (eceExitCode ece)) -getManifest :: (MonadIO m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> S9ErrT m LBS.ByteString -getManifest appmgrPath appPath e@(Extension appId) = do - (!ec, !bs) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "manifest", appPath <> show e] "" - case ec of - ExitSuccess -> pure bs - ExitFailure n -> throwE $ AppMgrE [i|embassy-sdk inspect manifest #{appId}|] n +getManifest :: (MonadUnliftIO m, KnownSymbol a) + => FilePath + -> FilePath + -> Extension a + -> (ConduitT () ByteString m () -> m r) + -> m r +getManifest appmgrPath appPath e@(Extension appId) sink = do + let appmgr = readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "manifest", appPath show e] "" + appmgr sink `catch` \ece -> throwIO (AppMgrE [i|embassy-sdk inspect manifest #{appId}|] (eceExitCode ece)) -getIcon :: (MonadIO m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> S9ErrT m LBS.ByteString -getIcon appmgrPath appPath (Extension icon) = do - (ec, bs) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "icon", appPath] "" - case ec of - ExitSuccess -> pure bs - ExitFailure n -> throwE $ AppMgrE [i|embassy-sdk inspect icon #{icon}|] n +getIcon :: (MonadUnliftIO m, KnownSymbol a) + => FilePath + -> FilePath + -> Extension a + -> (ConduitT () ByteString m () -> m r) + -> m r +getIcon appmgrPath appPath (Extension icon) sink = do + let appmgr = readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "icon", appPath] "" + appmgr sink `catch` \ece -> throwIO $ AppMgrE [i|embassy-sdk inspect icon #{icon}|] (eceExitCode ece) -getPackageHash :: (MonadIO m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> S9ErrT m LBS.ByteString +getPackageHash :: (MonadUnliftIO m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> m ByteString getPackageHash appmgrPath appPath e@(Extension appId) = do - (ec, bs) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "hash", appPath <> show e] "" - case ec of - ExitSuccess -> pure bs - ExitFailure n -> throwE $ AppMgrE [i|embassy-sdk inspect hash #{appId}|] n + let appmgr = readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "hash", appPath <> show e] "" + appmgr (\bsSource -> runConduit $ bsSource .| CL.foldMap id) + `catch` \ece -> throwIO $ AppMgrE [i|embassy-sdk inspect hash #{appId}|] (eceExitCode ece) -getInstructions :: (MonadIO m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> S9ErrT m LBS.ByteString -getInstructions appmgrPath appPath (Extension appId) = do - (ec, bs) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "instructions", appPath] "" - case ec of - ExitSuccess -> pure bs - ExitFailure n -> throwE $ AppMgrE [i|embassy-sdk inspect instructions #{appId}|] n +getInstructions :: (MonadUnliftIO m, KnownSymbol a) + => FilePath + -> FilePath + -> Extension a + -> (ConduitT () ByteString m () -> m r) + -> m r +getInstructions appmgrPath appPath (Extension appId) sink = do + let appmgr = readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "instructions", appPath] "" + appmgr sink `catch` \ece -> throwIO $ AppMgrE [i|embassy-sdk inspect instructions #{appId}|] (eceExitCode ece) -getLicense :: (MonadIO m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> S9ErrT m LBS.ByteString -getLicense appmgrPath appPath (Extension appId) = do - (ec, bs) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "license", appPath] "" - case ec of - ExitSuccess -> pure bs - ExitFailure n -> throwE $ AppMgrE [i|embassy-sdk inspect license #{appId}|] n +getLicense :: (MonadUnliftIO m, KnownSymbol a) + => FilePath + -> FilePath + -> Extension a + -> (ConduitT () ByteString m () -> m r) + -> m r +getLicense appmgrPath appPath (Extension appId) sink = do + let appmgr = readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "license", appPath] "" + appmgr sink `catch` \ece -> throwIO $ AppMgrE [i|embassy-sdk inspect license #{appId}|] (eceExitCode ece) + +sinkMem :: (Monad m, Monoid a) => ConduitT () a m () -> m a +sinkMem c = runConduit $ c .| CL.foldMap id diff --git a/src/Settings.hs b/src/Settings.hs index da08761..f6b9ed8 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -24,7 +24,6 @@ import System.FilePath ( () ) import Yesod.Default.Config2 ( configSettingsYml ) import Lib.Types.Emver -import Network.Wai ( FilePart ) import Orphans.Emver ( ) -- | Runtime settings to configure this application. These settings can be -- loaded from various sources: defaults, environment variables, config files, diff --git a/src/Util/Shared.hs b/src/Util/Shared.hs index 582f53b..7788608 100644 --- a/src/Util/Shared.hs +++ b/src/Util/Shared.hs @@ -8,13 +8,11 @@ import qualified Data.Text as T import Network.HTTP.Types import Yesod.Core +import Data.Semigroup import Foundation +import Lib.External.AppMgr import Lib.Registry import Lib.Types.Emver -import Data.Semigroup -import Lib.External.AppMgr -import Lib.Error -import qualified Data.ByteString.Lazy as BS getVersionFromQuery :: KnownSymbol a => FilePath -> Extension a -> Handler (Maybe Version) getVersionFromQuery rootDir ext = do @@ -36,7 +34,7 @@ getBestVersion rootDir ext spec = do let best = getMax <$> foldMap (Just . Max . fst . unRegisteredAppVersion) satisfactory pure best -addPackageHeader :: (MonadHandler m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> m () +addPackageHeader :: (MonadUnliftIO m, MonadHandler m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> m () addPackageHeader appMgrDir appDir appExt = do - packageHash <- handleS9ErrT $ getPackageHash appMgrDir appDir appExt - addHeader "X-S9PK-HASH" $ decodeUtf8 $ BS.toStrict packageHash + packageHash <- getPackageHash appMgrDir appDir appExt + addHeader "X-S9PK-HASH" $ decodeUtf8 packageHash From 9f97efe65210e623de2a2b92529829ac069daefb Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Mon, 27 Sep 2021 10:58:48 -0600 Subject: [PATCH 17/48] rename appmgr calls to be more descriptive of the API --- src/Handler/Apps.hs | 14 ++++---- src/Handler/Icons.hs | 21 ++++++------ src/Handler/Marketplace.hs | 6 ++-- src/Lib/External/AppMgr.hs | 70 +++++++++++++++++++------------------- 4 files changed, 56 insertions(+), 55 deletions(-) diff --git a/src/Handler/Apps.hs b/src/Handler/Apps.hs index b901df7..a4e5c4e 100644 --- a/src/Handler/Apps.hs +++ b/src/Handler/Apps.hs @@ -33,7 +33,6 @@ import Yesod.Persist.Core import Database.Queries import Foundation -import Lib.Error import Lib.External.AppMgr import Lib.Registry import Lib.Types.AppIndex @@ -79,10 +78,10 @@ getAppManifestR appId = do Just v -> pure v let appDir = (<> "/") . ( show av) . ( show appId) $ appsDir addPackageHeader appMgrDir appDir appExt - getManifest appMgrDir - appDir - appExt - (\bsSource -> respondSource "application/json" (bsSource .| awaitForever sendChunkBS)) + sourceManifest appMgrDir + appDir + appExt + (\bsSource -> respondSource "application/json" (bsSource .| awaitForever sendChunkBS)) where appExt = Extension (show appId) :: Extension "s9pk" getAppConfigR :: AppIdentifier -> Handler TypedContent @@ -95,7 +94,10 @@ getAppConfigR appId = do Just v -> pure v let appDir = (<> "/") . ( show av) . ( show appId) $ appsDir addPackageHeader appMgrDir appDir appExt - config <- getConfig appMgrDir appDir appExt (\bsSource -> _) + config <- sourceConfig appMgrDir + appDir + appExt + (\bsSource -> respondSource "application/json" (bsSource .| awaitForever sendChunkBS)) pure $ TypedContent "application/json" (toContent config) where appExt = Extension (show appId) :: Extension "s9pk" diff --git a/src/Handler/Icons.hs b/src/Handler/Icons.hs index 056c58e..fabdb92 100644 --- a/src/Handler/Icons.hs +++ b/src/Handler/Icons.hs @@ -19,7 +19,6 @@ import Data.Conduit ( (.|) ) import qualified Data.Conduit.List as CL import Foundation -import Lib.Error import Lib.External.AppMgr import Lib.Registry import Lib.Types.AppIndex @@ -45,7 +44,7 @@ getIconsR appId = do Nothing -> sendResponseStatus status404 ("Specified App Version Not Found" :: Text) Just v -> pure v let appDir = (<> "/") . ( show spec) . ( show appId) $ appsDir - manifest' <- getManifest appMgrDir appDir ext (\bsSource -> runConduit $ bsSource .| CL.foldMap BS.fromStrict) + manifest' <- sourceManifest appMgrDir appDir ext (\bsSource -> runConduit $ bsSource .| CL.foldMap BS.fromStrict) manifest <- case eitherDecode manifest' of Left e -> do $logError "could not parse service manifest!" @@ -66,10 +65,10 @@ getIconsR appId = do SVG -> pure typeSvg JPG -> pure typeJpeg JPEG -> pure typeJpeg - getIcon appMgrDir - (appDir show ext) - ext - (\bsSource -> respondSource mimeType (bsSource .| awaitForever sendChunkBS)) + sourceIcon appMgrDir + (appDir show ext) + ext + (\bsSource -> respondSource mimeType (bsSource .| awaitForever sendChunkBS)) where ext = Extension (show appId) :: Extension "s9pk" getLicenseR :: AppIdentifier -> Handler TypedContent @@ -82,7 +81,7 @@ getLicenseR appId = do case servicePath of Nothing -> notFound Just p -> - getLicense appMgrDir p ext (\bsSource -> respondSource typePlain (bsSource .| awaitForever sendChunkBS)) + sourceLicense appMgrDir p ext (\bsSource -> respondSource typePlain (bsSource .| awaitForever sendChunkBS)) where ext = Extension (show appId) :: Extension "s9pk" getInstructionsR :: AppIdentifier -> Handler TypedContent @@ -94,8 +93,8 @@ getInstructionsR appId = do servicePath <- liftIO $ getVersionedFileFromDir appsDir ext spec case servicePath of Nothing -> notFound - Just p -> getInstructions appMgrDir - p - ext - (\bsSource -> respondSource typePlain (bsSource .| awaitForever sendChunkBS)) + Just p -> sourceInstructions appMgrDir + p + ext + (\bsSource -> respondSource typePlain (bsSource .| awaitForever sendChunkBS)) where ext = Extension (show appId) :: Extension "s9pk" diff --git a/src/Handler/Marketplace.hs b/src/Handler/Marketplace.hs index 61567e2..5cc6c13 100644 --- a/src/Handler/Marketplace.hs +++ b/src/Handler/Marketplace.hs @@ -414,7 +414,7 @@ getServiceDetails settings metadata maybeVersion appId = do Just v -> pure v let appDir = (<> "/") . ( show version) . ( show appId) $ appsDir let appExt = Extension (show appId) :: Extension "s9pk" - manifest' <- getManifest appMgrDir appDir appExt (\bs -> sinkMem (bs .| mapC BS.fromStrict)) + manifest' <- sourceManifest appMgrDir appDir appExt (\bs -> sinkMem (bs .| mapC BS.fromStrict)) case eitherDecode $ manifest' of Left e -> pure $ Left $ "Could not parse service manifest for " <> show appId <> ": " <> show e Right m -> do @@ -467,7 +467,7 @@ decodeInstructions :: (MonadUnliftIO m, MonadHandler m, KnownSymbol a, MonadThro -> Extension a -> m Text decodeInstructions appmgrPath depPath package = do - getInstructions appmgrPath depPath package (\bs -> sinkMem (bs .| CT.decode CT.utf8)) + sourceInstructions appmgrPath depPath package (\bs -> sinkMem (bs .| CT.decode CT.utf8)) decodeLicense :: (MonadUnliftIO m, MonadThrow m, MonadHandler m, KnownSymbol a) => FilePath @@ -475,7 +475,7 @@ decodeLicense :: (MonadUnliftIO m, MonadThrow m, MonadHandler m, KnownSymbol a) -> Extension a -> m Text decodeLicense appmgrPath depPath package = - getLicense appmgrPath depPath package (\bs -> sinkMem (bs .| CT.decode CT.utf8)) + sourceLicense appmgrPath depPath package (\bs -> sinkMem (bs .| CT.decode CT.utf8)) fetchAllAppVersions :: Key SApp -> HandlerFor RegistryCtx ([VersionInfo], ReleaseNotes) fetchAllAppVersions appId = do diff --git a/src/Lib/External/AppMgr.hs b/src/Lib/External/AppMgr.hs index 56628e8..389dfe7 100644 --- a/src/Lib/External/AppMgr.hs +++ b/src/Lib/External/AppMgr.hs @@ -57,36 +57,36 @@ readProcessInheritStderr a b c sink = do $ System.Process.Typed.proc a b withProcessTerm_ pc $ \p -> sink (getStdout p) -getConfig :: (MonadUnliftIO m, MonadThrow m, KnownSymbol a) - => FilePath - -> FilePath - -> Extension a - -> (ConduitT () ByteString m () -> m r) - -> m r -getConfig appmgrPath appPath e@(Extension appId) sink = do +sourceConfig :: (MonadUnliftIO m, MonadThrow m, KnownSymbol a) + => FilePath + -> FilePath + -> Extension a + -> (ConduitT () ByteString m () -> m r) + -> m r +sourceConfig appmgrPath appPath e@(Extension appId) sink = do let appmgr = readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "config", appPath show e, "--json"] "" appmgr sink `catch` \ece -> throwIO (AppMgrE [i|inspect config #{appId} \--json|] (eceExitCode ece)) -getManifest :: (MonadUnliftIO m, KnownSymbol a) - => FilePath - -> FilePath - -> Extension a - -> (ConduitT () ByteString m () -> m r) - -> m r -getManifest appmgrPath appPath e@(Extension appId) sink = do +sourceManifest :: (MonadUnliftIO m, KnownSymbol a) + => FilePath + -> FilePath + -> Extension a + -> (ConduitT () ByteString m () -> m r) + -> m r +sourceManifest appmgrPath appPath e@(Extension appId) sink = do let appmgr = readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "manifest", appPath show e] "" appmgr sink `catch` \ece -> throwIO (AppMgrE [i|embassy-sdk inspect manifest #{appId}|] (eceExitCode ece)) -getIcon :: (MonadUnliftIO m, KnownSymbol a) - => FilePath - -> FilePath - -> Extension a - -> (ConduitT () ByteString m () -> m r) - -> m r -getIcon appmgrPath appPath (Extension icon) sink = do +sourceIcon :: (MonadUnliftIO m, KnownSymbol a) + => FilePath + -> FilePath + -> Extension a + -> (ConduitT () ByteString m () -> m r) + -> m r +sourceIcon appmgrPath appPath (Extension icon) sink = do let appmgr = readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "icon", appPath] "" appmgr sink `catch` \ece -> throwIO $ AppMgrE [i|embassy-sdk inspect icon #{icon}|] (eceExitCode ece) @@ -96,23 +96,23 @@ getPackageHash appmgrPath appPath e@(Extension appId) = do appmgr (\bsSource -> runConduit $ bsSource .| CL.foldMap id) `catch` \ece -> throwIO $ AppMgrE [i|embassy-sdk inspect hash #{appId}|] (eceExitCode ece) -getInstructions :: (MonadUnliftIO m, KnownSymbol a) - => FilePath - -> FilePath - -> Extension a - -> (ConduitT () ByteString m () -> m r) - -> m r -getInstructions appmgrPath appPath (Extension appId) sink = do +sourceInstructions :: (MonadUnliftIO m, KnownSymbol a) + => FilePath + -> FilePath + -> Extension a + -> (ConduitT () ByteString m () -> m r) + -> m r +sourceInstructions appmgrPath appPath (Extension appId) sink = do let appmgr = readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "instructions", appPath] "" appmgr sink `catch` \ece -> throwIO $ AppMgrE [i|embassy-sdk inspect instructions #{appId}|] (eceExitCode ece) -getLicense :: (MonadUnliftIO m, KnownSymbol a) - => FilePath - -> FilePath - -> Extension a - -> (ConduitT () ByteString m () -> m r) - -> m r -getLicense appmgrPath appPath (Extension appId) sink = do +sourceLicense :: (MonadUnliftIO m, KnownSymbol a) + => FilePath + -> FilePath + -> Extension a + -> (ConduitT () ByteString m () -> m r) + -> m r +sourceLicense appmgrPath appPath (Extension appId) sink = do let appmgr = readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "license", appPath] "" appmgr sink `catch` \ece -> throwIO $ AppMgrE [i|embassy-sdk inspect license #{appId}|] (eceExitCode ece) From 10eb17b0d361486c549fc5b1c1a82c5904a10f77 Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Mon, 27 Sep 2021 11:26:00 -0600 Subject: [PATCH 18/48] rename and degeneralize --- src/Handler/Marketplace.hs | 12 ++---------- src/Lib/External/AppMgr.hs | 34 +++++++--------------------------- 2 files changed, 9 insertions(+), 37 deletions(-) diff --git a/src/Handler/Marketplace.hs b/src/Handler/Marketplace.hs index 5cc6c13..47c838a 100644 --- a/src/Handler/Marketplace.hs +++ b/src/Handler/Marketplace.hs @@ -461,19 +461,11 @@ mapDependencyMetadata domain metadata (appId, depInfo) = do -- sendResponseStatus status400 e' -- Right (i' :: URL) -> pure $ i' <> T.pack icon -decodeInstructions :: (MonadUnliftIO m, MonadHandler m, KnownSymbol a, MonadThrow m) - => FilePath - -> FilePath - -> Extension a - -> m Text +decodeInstructions :: (MonadUnliftIO m, MonadHandler m, MonadThrow m) => FilePath -> FilePath -> S9PK -> m Text decodeInstructions appmgrPath depPath package = do sourceInstructions appmgrPath depPath package (\bs -> sinkMem (bs .| CT.decode CT.utf8)) -decodeLicense :: (MonadUnliftIO m, MonadThrow m, MonadHandler m, KnownSymbol a) - => FilePath - -> FilePath - -> Extension a - -> m Text +decodeLicense :: (MonadUnliftIO m, MonadThrow m, MonadHandler m) => FilePath -> FilePath -> S9PK -> m Text decodeLicense appmgrPath depPath package = sourceLicense appmgrPath depPath package (\bs -> sinkMem (bs .| CT.decode CT.utf8)) diff --git a/src/Lib/External/AppMgr.hs b/src/Lib/External/AppMgr.hs index 389dfe7..451b362 100644 --- a/src/Lib/External/AppMgr.hs +++ b/src/Lib/External/AppMgr.hs @@ -57,10 +57,10 @@ readProcessInheritStderr a b c sink = do $ System.Process.Typed.proc a b withProcessTerm_ pc $ \p -> sink (getStdout p) -sourceConfig :: (MonadUnliftIO m, MonadThrow m, KnownSymbol a) +sourceConfig :: (MonadUnliftIO m, MonadThrow m) => FilePath -> FilePath - -> Extension a + -> S9PK -> (ConduitT () ByteString m () -> m r) -> m r sourceConfig appmgrPath appPath e@(Extension appId) sink = do @@ -70,48 +70,28 @@ sourceConfig appmgrPath appPath e@(Extension appId) sink = do "" appmgr sink `catch` \ece -> throwIO (AppMgrE [i|inspect config #{appId} \--json|] (eceExitCode ece)) -sourceManifest :: (MonadUnliftIO m, KnownSymbol a) - => FilePath - -> FilePath - -> Extension a - -> (ConduitT () ByteString m () -> m r) - -> m r +sourceManifest :: (MonadUnliftIO m) => FilePath -> FilePath -> S9PK -> (ConduitT () ByteString m () -> m r) -> m r sourceManifest appmgrPath appPath e@(Extension appId) sink = do let appmgr = readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "manifest", appPath show e] "" appmgr sink `catch` \ece -> throwIO (AppMgrE [i|embassy-sdk inspect manifest #{appId}|] (eceExitCode ece)) -sourceIcon :: (MonadUnliftIO m, KnownSymbol a) - => FilePath - -> FilePath - -> Extension a - -> (ConduitT () ByteString m () -> m r) - -> m r +sourceIcon :: (MonadUnliftIO m) => FilePath -> FilePath -> S9PK -> (ConduitT () ByteString m () -> m r) -> m r sourceIcon appmgrPath appPath (Extension icon) sink = do let appmgr = readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "icon", appPath] "" appmgr sink `catch` \ece -> throwIO $ AppMgrE [i|embassy-sdk inspect icon #{icon}|] (eceExitCode ece) -getPackageHash :: (MonadUnliftIO m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> m ByteString +getPackageHash :: (MonadUnliftIO m) => FilePath -> FilePath -> S9PK -> m ByteString getPackageHash appmgrPath appPath e@(Extension appId) = do let appmgr = readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "hash", appPath <> show e] "" appmgr (\bsSource -> runConduit $ bsSource .| CL.foldMap id) `catch` \ece -> throwIO $ AppMgrE [i|embassy-sdk inspect hash #{appId}|] (eceExitCode ece) -sourceInstructions :: (MonadUnliftIO m, KnownSymbol a) - => FilePath - -> FilePath - -> Extension a - -> (ConduitT () ByteString m () -> m r) - -> m r +sourceInstructions :: (MonadUnliftIO m) => FilePath -> FilePath -> S9PK -> (ConduitT () ByteString m () -> m r) -> m r sourceInstructions appmgrPath appPath (Extension appId) sink = do let appmgr = readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "instructions", appPath] "" appmgr sink `catch` \ece -> throwIO $ AppMgrE [i|embassy-sdk inspect instructions #{appId}|] (eceExitCode ece) -sourceLicense :: (MonadUnliftIO m, KnownSymbol a) - => FilePath - -> FilePath - -> Extension a - -> (ConduitT () ByteString m () -> m r) - -> m r +sourceLicense :: (MonadUnliftIO m) => FilePath -> FilePath -> S9PK -> (ConduitT () ByteString m () -> m r) -> m r sourceLicense appmgrPath appPath (Extension appId) sink = do let appmgr = readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "license", appPath] "" appmgr sink `catch` \ece -> throwIO $ AppMgrE [i|embassy-sdk inspect license #{appId}|] (eceExitCode ece) From 615def8d3ac24c7638ce70c751912e0818973656 Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Mon, 27 Sep 2021 11:33:11 -0600 Subject: [PATCH 19/48] rename AppIdentifier to PkgId to save typing and reflect new name terminology --- config/routes | 10 +++---- src/Database/Queries.hs | 6 ++-- src/Handler/Apps.hs | 6 ++-- src/Handler/Icons.hs | 6 ++-- src/Handler/Marketplace.hs | 37 ++++++++++++----------- src/Lib/Types/AppIndex.hs | 60 +++++++++++++++++++------------------- src/Model.hs | 8 ++--- src/Util/Shared.hs | 2 +- 8 files changed, 67 insertions(+), 68 deletions(-) diff --git a/config/routes b/config/routes index c3d7c57..f5f4058 100644 --- a/config/routes +++ b/config/routes @@ -4,14 +4,14 @@ -- /package/updates /eos/latest EosR GET -- get eos information /latest-version VersionLatestR GET -- get latest version of apps in query param id -/package/manifest/#AppIdentifier AppManifestR GET -- get app manifest from appmgr -- ?version={semver-spec} +/package/manifest/#PkgId AppManifestR GET -- get app manifest from appmgr -- ?version={semver-spec} /package/release-notes ReleaseNotesR GET -- get release notes for package - expects query param of id= -/package/icon/#AppIdentifier IconsR GET -- get icons - can specify version with ?spec= -/package/license/#AppIdentifier LicenseR GET -- get icons - can specify version with ?spec= -/package/instructions/#AppIdentifier InstructionsR GET -- get icons - can specify version with ?spec= +/package/icon/#PkgId IconsR GET -- get icons - can specify version with ?spec= +/package/license/#PkgId LicenseR GET -- get icons - can specify version with ?spec= +/package/instructions/#PkgId InstructionsR GET -- get icons - can specify version with ?spec= -- TODO confirm needed -/package/config/#AppIdentifier AppConfigR GET -- get app config from appmgr -- ?spec={semver-spec} +/package/config/#PkgId AppConfigR GET -- get app config from appmgr -- ?spec={semver-spec} /package/version/#Text VersionAppR GET -- get most recent appId version !/sys/#SYS_EXTENSIONLESS SysR GET -- get most recent sys app -- ?spec={semver-spec} /version VersionR GET diff --git a/src/Database/Queries.hs b/src/Database/Queries.hs index 5fbf2e2..a2decd5 100644 --- a/src/Database/Queries.hs +++ b/src/Database/Queries.hs @@ -4,20 +4,20 @@ module Database.Queries where -import Startlude import Database.Persist.Sql import Lib.Types.AppIndex import Lib.Types.Emver import Model import Orphans.Emver ( ) +import Startlude -fetchApp :: MonadIO m => AppIdentifier -> ReaderT SqlBackend m (Maybe (Entity SApp)) +fetchApp :: MonadIO m => PkgId -> ReaderT SqlBackend m (Maybe (Entity SApp)) fetchApp appId = selectFirst [SAppAppId ==. appId] [] fetchAppVersion :: MonadIO m => Version -> Key SApp -> ReaderT SqlBackend m (Maybe (Entity SVersion)) fetchAppVersion appVersion appId = selectFirst [SVersionNumber ==. appVersion, SVersionAppId ==. appId] [] -createApp :: MonadIO m => AppIdentifier -> StoreApp -> ReaderT SqlBackend m (Maybe (Key SApp)) +createApp :: MonadIO m => PkgId -> StoreApp -> ReaderT SqlBackend m (Maybe (Key SApp)) createApp appId StoreApp {..} = do time <- liftIO getCurrentTime insertUnique $ SApp time Nothing storeAppTitle appId storeAppDescShort storeAppDescLong storeAppIconType diff --git a/src/Handler/Apps.hs b/src/Handler/Apps.hs index a4e5c4e..91f8701 100644 --- a/src/Handler/Apps.hs +++ b/src/Handler/Apps.hs @@ -70,7 +70,7 @@ getSysR e = do -- @TODO update with new response type here getApp sysResourceDir e -getAppManifestR :: AppIdentifier -> Handler TypedContent +getAppManifestR :: PkgId -> Handler TypedContent getAppManifestR appId = do (appsDir, appMgrDir) <- getsYesod $ (( "apps") . resourcesDir &&& staticBinDir) . appSettings av <- getVersionFromQuery appsDir appExt >>= \case @@ -84,7 +84,7 @@ getAppManifestR appId = do (\bsSource -> respondSource "application/json" (bsSource .| awaitForever sendChunkBS)) where appExt = Extension (show appId) :: Extension "s9pk" -getAppConfigR :: AppIdentifier -> Handler TypedContent +getAppConfigR :: PkgId -> Handler TypedContent getAppConfigR appId = do appSettings <- appSettings <$> getYesod let appsDir = ( "apps") . resourcesDir $ appSettings @@ -146,7 +146,7 @@ chunkIt fp = do recordMetrics :: String -> Version -> HandlerFor RegistryCtx () recordMetrics appId appVersion = do let appId' = T.pack appId - sa <- runDB $ fetchApp $ AppIdentifier appId' + sa <- runDB $ fetchApp $ PkgId appId' case sa of Nothing -> do $logError $ appId' <> " not found in database" diff --git a/src/Handler/Icons.hs b/src/Handler/Icons.hs index fabdb92..5fed13b 100644 --- a/src/Handler/Icons.hs +++ b/src/Handler/Icons.hs @@ -37,7 +37,7 @@ instance FromJSON IconType ixt :: Text ixt = toS $ toUpper <$> drop 1 ".png" -getIconsR :: AppIdentifier -> Handler TypedContent +getIconsR :: PkgId -> Handler TypedContent getIconsR appId = do (appsDir, appMgrDir) <- getsYesod $ (( "apps") . resourcesDir &&& staticBinDir) . appSettings spec <- getVersionFromQuery appsDir ext >>= \case @@ -71,7 +71,7 @@ getIconsR appId = do (\bsSource -> respondSource mimeType (bsSource .| awaitForever sendChunkBS)) where ext = Extension (show appId) :: Extension "s9pk" -getLicenseR :: AppIdentifier -> Handler TypedContent +getLicenseR :: PkgId -> Handler TypedContent getLicenseR appId = do (appsDir, appMgrDir) <- getsYesod $ (( "apps") . resourcesDir &&& staticBinDir) . appSettings spec <- getVersionFromQuery appsDir ext >>= \case @@ -84,7 +84,7 @@ getLicenseR appId = do sourceLicense appMgrDir p ext (\bsSource -> respondSource typePlain (bsSource .| awaitForever sendChunkBS)) where ext = Extension (show appId) :: Extension "s9pk" -getInstructionsR :: AppIdentifier -> Handler TypedContent +getInstructionsR :: PkgId -> Handler TypedContent getInstructionsR appId = do (appsDir, appMgrDir) <- getsYesod $ (( "apps") . resourcesDir &&& staticBinDir) . appSettings spec <- getVersionFromQuery appsDir ext >>= \case diff --git a/src/Handler/Marketplace.hs b/src/Handler/Marketplace.hs index 47c838a..0c2c305 100644 --- a/src/Handler/Marketplace.hs +++ b/src/Handler/Marketplace.hs @@ -66,7 +66,7 @@ data ServiceRes = ServiceRes , serviceResInstructions :: URL , serviceResLicense :: URL , serviceResVersions :: [Version] - , serviceResDependencyInfo :: HM.HashMap AppIdentifier DependencyInfo + , serviceResDependencyInfo :: HM.HashMap PkgId DependencyInfo } deriving Generic @@ -93,7 +93,7 @@ instance ToContent ServiceRes where instance ToTypedContent ServiceRes where toTypedContent = toTypedContent . toJSON data DependencyInfo = DependencyInfo - { dependencyInfoTitle :: AppIdentifier + { dependencyInfoTitle :: PkgId , dependencyInfoIcon :: URL } deriving (Eq, Show) @@ -114,7 +114,7 @@ instance ToTypedContent ServiceListRes where toTypedContent = toTypedContent . toJSON data ServiceAvailable = ServiceAvailable - { serviceAvailableId :: AppIdentifier + { serviceAvailableId :: PkgId , serviceAvailableTitle :: Text , serviceAvailableVersion :: Version , serviceAvailableIcon :: URL @@ -142,7 +142,7 @@ instance ToContent ServiceAvailableRes where instance ToTypedContent ServiceAvailableRes where toTypedContent = toTypedContent . toJSON -newtype VersionLatestRes = VersionLatestRes (HM.HashMap AppIdentifier (Maybe Version)) +newtype VersionLatestRes = VersionLatestRes (HM.HashMap PkgId (Maybe Version)) deriving (Show, Generic) instance ToJSON VersionLatestRes instance ToContent VersionLatestRes where @@ -174,7 +174,7 @@ instance ToTypedContent EosRes where toTypedContent = toTypedContent . toJSON data PackageVersion = PackageVersion - { packageVersionId :: AppIdentifier + { packageVersionId :: PkgId , packageVersionVersion :: VersionRange } deriving Show @@ -217,8 +217,7 @@ getReleaseNotesR = do case lookup "id" getParameters of Nothing -> sendResponseStatus status400 ("expected query param \"id\" to exist" :: Text) Just package -> do - (service, _) <- runDB $ fetchLatestApp (AppIdentifier package) >>= errOnNothing status404 - "package not found" + (service, _) <- runDB $ fetchLatestApp (PkgId package) >>= errOnNothing status404 "package not found" (_, mappedVersions) <- fetchAllAppVersions (entityKey service) pure mappedVersions @@ -229,8 +228,8 @@ getVersionLatestR = do Nothing -> sendResponseStatus status400 ("expected query param \"ids\" to exist" :: Text) Just packages -> case eitherDecode $ BS.fromStrict $ encodeUtf8 packages of Left e -> sendResponseStatus status400 ("could not parse query param \"ids\"" <> show e :: Text) - Right (p :: [AppIdentifier]) -> do - let packageList :: [(AppIdentifier, Maybe Version)] = (, Nothing) <$> p + Right (p :: [PkgId]) -> do + let packageList :: [(PkgId, Maybe Version)] = (, Nothing) <$> p found <- runDB $ traverse fetchLatestApp $ fst <$> packageList pure $ VersionLatestRes @@ -370,9 +369,9 @@ getPackageListR = do where getPackageDetails :: MonadIO m - => (HM.HashMap AppIdentifier ([Version], [CategoryTitle])) + => (HM.HashMap PkgId ([Version], [CategoryTitle])) -> PackageVersion - -> m (Either Text ((Maybe Version), AppIdentifier)) + -> m (Either Text ((Maybe Version), PkgId)) getPackageDetails metadata pv = do let appId = packageVersionId pv let spec = packageVersionVersion pv @@ -395,9 +394,9 @@ getPackageListR = do getServiceDetails :: (MonadUnliftIO m, Monad m, MonadError IOException m) => AppSettings - -> (HM.HashMap AppIdentifier ([Version], [CategoryTitle])) + -> (HM.HashMap PkgId ([Version], [CategoryTitle])) -> Maybe Version - -> AppIdentifier + -> PkgId -> m (Either Text ServiceRes) getServiceDetails settings metadata maybeVersion appId = do packageMetadata <- case HM.lookup appId metadata of @@ -432,9 +431,9 @@ getServiceDetails settings metadata maybeVersion appId = do mapDependencyMetadata :: (MonadIO m) => Text - -> HM.HashMap AppIdentifier ([Version], [CategoryTitle]) - -> (AppIdentifier, ServiceDependencyInfo) - -> m (Either Text (AppIdentifier, DependencyInfo)) + -> HM.HashMap PkgId ([Version], [CategoryTitle]) + -> (PkgId, ServiceDependencyInfo) + -> m (Either Text (PkgId, DependencyInfo)) mapDependencyMetadata domain metadata (appId, depInfo) = do depMetadata <- case HM.lookup appId metadata of Nothing -> throwIO $ NotFoundE [i|dependency metadata for #{appId} not found.|] @@ -497,7 +496,7 @@ fetchMostRecentAppVersions appId = select $ do limit 1 pure version -fetchLatestApp :: MonadIO m => AppIdentifier -> ReaderT SqlBackend m (Maybe (P.Entity SApp, P.Entity SVersion)) +fetchLatestApp :: MonadIO m => PkgId -> ReaderT SqlBackend m (Maybe (P.Entity SApp, P.Entity SVersion)) fetchLatestApp appId = selectOne $ do (service :& version) <- from @@ -509,7 +508,7 @@ fetchLatestApp appId = selectOne $ do pure (service, version) fetchLatestAppAtVersion :: MonadIO m - => AppIdentifier + => PkgId -> Version -> ReaderT SqlBackend m (Maybe (P.Entity SApp, P.Entity SVersion)) fetchLatestAppAtVersion appId version' = selectOne $ do @@ -522,7 +521,7 @@ fetchLatestAppAtVersion appId version' = selectOne $ do pure (service, version) fetchPackageMetadata :: (MonadLogger m, MonadUnliftIO m) - => ReaderT SqlBackend m (HM.HashMap AppIdentifier ([Version], [CategoryTitle])) + => ReaderT SqlBackend m (HM.HashMap PkgId ([Version], [CategoryTitle])) fetchPackageMetadata = do let categoriesQuery = select $ do (service :& category) <- diff --git a/src/Lib/Types/AppIndex.hs b/src/Lib/Types/AppIndex.hs index 9b42595..a6d23d4 100644 --- a/src/Lib/Types/AppIndex.hs +++ b/src/Lib/Types/AppIndex.hs @@ -28,42 +28,42 @@ import Orphans.Emver ( ) import System.Directory import Yesod -newtype AppIdentifier = AppIdentifier { unAppIdentifier :: Text } - deriving (Eq) -instance IsString AppIdentifier where - fromString = AppIdentifier . fromString -instance Show AppIdentifier where - show = toS . unAppIdentifier -instance Read AppIdentifier where - readsPrec _ s = [(AppIdentifier $ toS s, "")] -instance Hashable AppIdentifier where - hashWithSalt n = hashWithSalt n . unAppIdentifier -instance FromJSON AppIdentifier where - parseJSON = fmap AppIdentifier . parseJSON -instance ToJSON AppIdentifier where - toJSON = toJSON . unAppIdentifier -instance FromJSONKey AppIdentifier where - fromJSONKey = fmap AppIdentifier fromJSONKey -instance ToJSONKey AppIdentifier where - toJSONKey = contramap unAppIdentifier toJSONKey -instance PersistField AppIdentifier where +newtype PkgId = PkgId { unPkgId :: Text } + deriving (Eq) +instance IsString PkgId where + fromString = PkgId . fromString +instance Show PkgId where + show = toS . unPkgId +instance Read PkgId where + readsPrec _ s = [(PkgId $ toS s, "")] +instance Hashable PkgId where + hashWithSalt n = hashWithSalt n . unPkgId +instance FromJSON PkgId where + parseJSON = fmap PkgId . parseJSON +instance ToJSON PkgId where + toJSON = toJSON . unPkgId +instance FromJSONKey PkgId where + fromJSONKey = fmap PkgId fromJSONKey +instance ToJSONKey PkgId where + toJSONKey = contramap unPkgId toJSONKey +instance PersistField PkgId where toPersistValue = PersistText . show - fromPersistValue (PersistText t) = Right . AppIdentifier $ toS t + fromPersistValue (PersistText t) = Right . PkgId $ toS t fromPersistValue other = Left $ "Invalid AppId: " <> show other -instance PersistFieldSql AppIdentifier where +instance PersistFieldSql PkgId where sqlType _ = SqlString -instance PathPiece AppIdentifier where - fromPathPiece = fmap AppIdentifier . fromPathPiece - toPathPiece = unAppIdentifier -instance ToContent AppIdentifier where +instance PathPiece PkgId where + fromPathPiece = fmap PkgId . fromPathPiece + toPathPiece = unPkgId +instance ToContent PkgId where toContent = toContent . toJSON -instance ToTypedContent AppIdentifier where +instance ToTypedContent PkgId where toTypedContent = toTypedContent . toJSON data VersionInfo = VersionInfo { versionInfoVersion :: Version , versionInfoReleaseNotes :: Text - , versionInfoDependencies :: HM.HashMap AppIdentifier VersionRange + , versionInfoDependencies :: HM.HashMap PkgId VersionRange , versionInfoOsRequired :: VersionRange , versionInfoOsRecommended :: VersionRange , versionInfoInstallAlert :: Maybe Text @@ -111,7 +111,7 @@ instance ToJSON StoreApp where , "version-info" .= storeAppVersionInfo , "timestamp" .= storeAppTimestamp ] -newtype AppManifest = AppManifest { unAppManifest :: HM.HashMap AppIdentifier StoreApp} +newtype AppManifest = AppManifest { unAppManifest :: HM.HashMap PkgId StoreApp} deriving (Show) instance FromJSON AppManifest where @@ -186,7 +186,7 @@ instance FromJSON ServiceAlert where "stop" -> pure STOP _ -> fail "unknown service alert type" data ServiceManifest = ServiceManifest - { serviceManifestId :: !AppIdentifier + { serviceManifestId :: !PkgId , serviceManifestTitle :: !Text , serviceManifestVersion :: !Version , serviceManifestDescriptionLong :: !Text @@ -194,7 +194,7 @@ data ServiceManifest = ServiceManifest , serviceManifestReleaseNotes :: !Text , serviceManifestIcon :: !(Maybe Text) , serviceManifestAlerts :: !(HM.HashMap ServiceAlert (Maybe Text)) - , serviceManifestDependencies :: !(HM.HashMap AppIdentifier ServiceDependencyInfo) + , serviceManifestDependencies :: !(HM.HashMap PkgId ServiceDependencyInfo) } deriving Show instance FromJSON ServiceManifest where diff --git a/src/Model.hs b/src/Model.hs index b2dacd9..1527183 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -10,19 +10,19 @@ module Model where -import Startlude import Database.Persist.TH -import Lib.Types.Emver +import Lib.Types.AppIndex import Lib.Types.Category +import Lib.Types.Emver import Orphans.Emver ( ) -import Lib.Types.AppIndex +import Startlude share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| SApp createdAt UTCTime updatedAt UTCTime Maybe title Text - appId AppIdentifier + appId PkgId descShort Text descLong Text iconType Text diff --git a/src/Util/Shared.hs b/src/Util/Shared.hs index 7788608..4eb3c41 100644 --- a/src/Util/Shared.hs +++ b/src/Util/Shared.hs @@ -34,7 +34,7 @@ getBestVersion rootDir ext spec = do let best = getMax <$> foldMap (Just . Max . fst . unRegisteredAppVersion) satisfactory pure best -addPackageHeader :: (MonadUnliftIO m, MonadHandler m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> m () +addPackageHeader :: (MonadUnliftIO m, MonadHandler m) => FilePath -> FilePath -> S9PK -> m () addPackageHeader appMgrDir appDir appExt = do packageHash <- getPackageHash appMgrDir appDir appExt addHeader "X-S9PK-HASH" $ decodeUtf8 packageHash From 36e78f7177ca0b262a5ac7242cee00e8c8325b6c Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Mon, 27 Sep 2021 15:21:43 -0600 Subject: [PATCH 20/48] upgrade to GHC 8.10.7 --- package.yaml | 111 ++++++++++++++++++++++++++------------------------- stack.yaml | 2 +- 2 files changed, 57 insertions(+), 56 deletions(-) diff --git a/package.yaml b/package.yaml index 2e574e3..fdde926 100644 --- a/package.yaml +++ b/package.yaml @@ -2,63 +2,64 @@ name: start9-registry version: 0.1.0 default-extensions: -- FlexibleInstances -- GeneralizedNewtypeDeriving -- LambdaCase -- MultiWayIf -- NamedFieldPuns -- NoImplicitPrelude -- NumericUnderscores -- OverloadedStrings -- StandaloneDeriving + - FlexibleInstances + - GeneralizedNewtypeDeriving + - LambdaCase + - MultiWayIf + - NamedFieldPuns + - NoImplicitPrelude + - NumericUnderscores + - OverloadedStrings + - StandaloneDeriving dependencies: -- base >=4.12 && <5 -- aeson -- attoparsec -- binary -- bytestring -- casing -- conduit -- conduit-extra -- data-default -- directory -- errors -- esqueleto -- extra -- file-embed -- fast-logger -- filepath -- foreign-store -- http-types -- interpolate -- lens -- monad-logger -- persistent -- persistent-postgresql -- persistent-template -- postgresql-simple -- process -- protolude -- shakespeare -- template-haskell -- text -- text-conversions -- time -- transformers -- typed-process -- unliftio -- unordered-containers -- unix -- wai -- wai-cors -- wai-extra -- warp -- warp-tls -- yaml -- yesod -- yesod-core -- yesod-persistent + - base >=4.12 && <5 + - aeson + - attoparsec + - binary + - bytestring + - casing + - can-i-haz + - conduit + - conduit-extra + - data-default + - directory + - errors + - esqueleto + - extra + - file-embed + - fast-logger + - filepath + - foreign-store + - http-types + - interpolate + - lens + - monad-logger + - persistent + - persistent-postgresql + - persistent-template + - postgresql-simple + - process + - protolude + - shakespeare + - template-haskell + - text + - text-conversions + - time + - transformers + - typed-process + - unliftio + - unordered-containers + - unix + - wai + - wai-cors + - wai-extra + - warp + - warp-tls + - yaml + - yesod + - yesod-core + - yesod-persistent library: source-dirs: src diff --git a/stack.yaml b/stack.yaml index aa4d54e..167ce3e 100644 --- a/stack.yaml +++ b/stack.yaml @@ -17,7 +17,7 @@ # # resolver: ./custom-snapshot.yaml # resolver: https://example.com/snapshots/2018-01-01.yaml -resolver: lts-18.6 +resolver: lts-18.11 # User packages to be built. # Various formats can be used as shown in the example below. From 20469c2071b306eb44606e6f8974863d75641e8a Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Mon, 27 Sep 2021 15:22:12 -0600 Subject: [PATCH 21/48] remove function that is invalid for 0.3 appmgr --- src/Lib/External/AppMgr.hs | 13 ------------- 1 file changed, 13 deletions(-) diff --git a/src/Lib/External/AppMgr.hs b/src/Lib/External/AppMgr.hs index 451b362..b650b27 100644 --- a/src/Lib/External/AppMgr.hs +++ b/src/Lib/External/AppMgr.hs @@ -57,19 +57,6 @@ readProcessInheritStderr a b c sink = do $ System.Process.Typed.proc a b withProcessTerm_ pc $ \p -> sink (getStdout p) -sourceConfig :: (MonadUnliftIO m, MonadThrow m) - => FilePath - -> FilePath - -> S9PK - -> (ConduitT () ByteString m () -> m r) - -> m r -sourceConfig appmgrPath appPath e@(Extension appId) sink = do - let - appmgr = readProcessInheritStderr (appmgrPath <> "embassy-sdk") - ["inspect", "config", appPath show e, "--json"] - "" - appmgr sink `catch` \ece -> throwIO (AppMgrE [i|inspect config #{appId} \--json|] (eceExitCode ece)) - sourceManifest :: (MonadUnliftIO m) => FilePath -> FilePath -> S9PK -> (ConduitT () ByteString m () -> m r) -> m r sourceManifest appmgrPath appPath e@(Extension appId) sink = do let appmgr = readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "manifest", appPath show e] "" From 7420065c88919b5e727ca4e4d11ee84745847812 Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Mon, 27 Sep 2021 15:22:29 -0600 Subject: [PATCH 22/48] remove dead code --- src/Handler/Marketplace.hs | 9 --------- 1 file changed, 9 deletions(-) diff --git a/src/Handler/Marketplace.hs b/src/Handler/Marketplace.hs index 0c2c305..65c7f95 100644 --- a/src/Handler/Marketplace.hs +++ b/src/Handler/Marketplace.hs @@ -451,15 +451,6 @@ mapDependencyMetadata domain metadata (appId, depInfo) = do } ) --- decodeIcon :: (MonadHandler m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> m URL --- decodeIcon appmgrPath depPath e@(Extension icon) = do --- icon' <- handleS9ErrT $ getIcon appmgrPath depPath e --- case eitherDecode icon' of --- Left e' -> do --- $logInfo $ T.pack e' --- sendResponseStatus status400 e' --- Right (i' :: URL) -> pure $ i' <> T.pack icon - decodeInstructions :: (MonadUnliftIO m, MonadHandler m, MonadThrow m) => FilePath -> FilePath -> S9PK -> m Text decodeInstructions appmgrPath depPath package = do sourceInstructions appmgrPath depPath package (\bs -> sinkMem (bs .| CT.decode CT.utf8)) From a3f7d274732dbc484a324ad7df3eea3120a5e0e7 Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Mon, 27 Sep 2021 15:42:26 -0600 Subject: [PATCH 23/48] more dead code removal --- src/Handler/Marketplace.hs | 69 -------------------------------------- 1 file changed, 69 deletions(-) diff --git a/src/Handler/Marketplace.hs b/src/Handler/Marketplace.hs index 65c7f95..13d26d7 100644 --- a/src/Handler/Marketplace.hs +++ b/src/Handler/Marketplace.hs @@ -283,9 +283,6 @@ getPackageListR = do $ mapConcurrently (getServiceDetails settings packageMetadata Nothing) filteredServices' let (_, services) = partitionEithers serviceDetailResult pure $ ServiceAvailableRes services - -- if null errors - -- then pure $ ServiceAvailableRes services - -- else sendResponseStatus status500 ("Errors acquiring service details: " <> show <$> errors) Just packageVersionList -> case eitherDecode $ BS.fromStrict $ encodeUtf8 packageVersionList of Left e -> sendResponseStatus status400 ("could not parse query param \"ids\"" <> show e :: Text) @@ -301,72 +298,6 @@ getPackageListR = do -- @TODO fix _ error let (_, services) = partitionEithers serviceDetailResult pure $ ServiceAvailableRes services - -- if null errors - -- then pure $ ServiceAvailableRes services - -- else sendResponseStatus status500 ("Errors acquiring service details: " <> show <$> errors) - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - where getPackageDetails :: MonadIO m => (HM.HashMap PkgId ([Version], [CategoryTitle])) From 718851c7566fdeb52ccf783a53c3d5de6cd5e529 Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Mon, 27 Sep 2021 15:47:15 -0600 Subject: [PATCH 24/48] cleanup usages of removed appmgr call --- config/routes | 1 - src/Handler/Apps.hs | 17 ----------------- 2 files changed, 18 deletions(-) diff --git a/config/routes b/config/routes index f5f4058..d87e1be 100644 --- a/config/routes +++ b/config/routes @@ -11,7 +11,6 @@ /package/instructions/#PkgId InstructionsR GET -- get icons - can specify version with ?spec= -- TODO confirm needed -/package/config/#PkgId AppConfigR GET -- get app config from appmgr -- ?spec={semver-spec} /package/version/#Text VersionAppR GET -- get most recent appId version !/sys/#SYS_EXTENSIONLESS SysR GET -- get most recent sys app -- ?spec={semver-spec} /version VersionR GET diff --git a/src/Handler/Apps.hs b/src/Handler/Apps.hs index 91f8701..531cace 100644 --- a/src/Handler/Apps.hs +++ b/src/Handler/Apps.hs @@ -84,23 +84,6 @@ getAppManifestR appId = do (\bsSource -> respondSource "application/json" (bsSource .| awaitForever sendChunkBS)) where appExt = Extension (show appId) :: Extension "s9pk" -getAppConfigR :: PkgId -> Handler TypedContent -getAppConfigR appId = do - appSettings <- appSettings <$> getYesod - let appsDir = ( "apps") . resourcesDir $ appSettings - let appMgrDir = staticBinDir appSettings - av <- getVersionFromQuery appsDir appExt >>= \case - Nothing -> sendResponseStatus status404 ("Specified App Version Not Found" :: Text) - Just v -> pure v - let appDir = (<> "/") . ( show av) . ( show appId) $ appsDir - addPackageHeader appMgrDir appDir appExt - config <- sourceConfig appMgrDir - appDir - appExt - (\bsSource -> respondSource "application/json" (bsSource .| awaitForever sendChunkBS)) - pure $ TypedContent "application/json" (toContent config) - where appExt = Extension (show appId) :: Extension "s9pk" - getAppR :: Extension "s9pk" -> Handler TypedContent getAppR e = do appResourceDir <- ( "apps") . resourcesDir . appSettings <$> getYesod From 7a4e0d8f0e3cc2fa31bf5e925dea2581403dc3c6 Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Mon, 27 Sep 2021 18:07:49 -0600 Subject: [PATCH 25/48] fsnotify extraction attempt --- package.yaml | 1 + src/Application.hs | 150 ++++++++++++++++++++-------------- src/Foundation.hs | 13 +++ src/Lib/External/AppMgr.hs | 1 - src/Lib/PkgRepository.hs | 160 +++++++++++++++++++++++++++++++++++++ src/Settings.hs | 8 ++ 6 files changed, 270 insertions(+), 63 deletions(-) create mode 100644 src/Lib/PkgRepository.hs diff --git a/package.yaml b/package.yaml index fdde926..111f690 100644 --- a/package.yaml +++ b/package.yaml @@ -31,6 +31,7 @@ dependencies: - fast-logger - filepath - foreign-store + - fsnotify - http-types - interpolate - lens diff --git a/src/Application.hs b/src/Application.hs index d79ce17..993fb37 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -24,51 +24,79 @@ module Application , getAppSettings -- * for GHCI , handler - ,db) where + , db + ) where -import Startlude hiding (Handler) +import Startlude hiding ( Handler ) -import Control.Monad.Logger (liftLoc, runLoggingT) +import Control.Monad.Logger ( liftLoc + , runLoggingT + ) import Data.Default -import Database.Persist.Postgresql (createPostgresqlPool, pgConnStr, pgPoolSize, runSqlPool, runMigration) -import Language.Haskell.TH.Syntax (qLocation) +import Database.Persist.Postgresql ( createPostgresqlPool + , pgConnStr + , pgPoolSize + , runMigration + , runSqlPool + ) +import Language.Haskell.TH.Syntax ( qLocation ) import Network.Wai -import Network.Wai.Handler.Warp (Settings, defaultSettings, defaultShouldDisplayException, - getPort, setHost, setOnException, setPort, runSettings, setHTTP2Disabled) +import Network.Wai.Handler.Warp ( Settings + , defaultSettings + , defaultShouldDisplayException + , getPort + , runSettings + , setHTTP2Disabled + , setHost + , setOnException + , setPort + ) import Network.Wai.Handler.WarpTLS import Network.Wai.Middleware.AcceptOverride import Network.Wai.Middleware.Autohead -import Network.Wai.Middleware.Cors (CorsResourcePolicy (..), cors, simpleCorsResourcePolicy) +import Network.Wai.Middleware.Cors ( CorsResourcePolicy(..) + , cors + , simpleCorsResourcePolicy + ) import Network.Wai.Middleware.MethodOverride -import Network.Wai.Middleware.RequestLogger (Destination (Logger), OutputFormat (..), - destination, mkRequestLogger, outputFormat) -import System.IO (hSetBuffering, BufferMode (..)) -import System.Log.FastLogger (defaultBufSize, newStdoutLoggerSet, toLogStr) +import Network.Wai.Middleware.RequestLogger + ( Destination(Logger) + , OutputFormat(..) + , destination + , mkRequestLogger + , outputFormat + ) +import System.IO ( BufferMode(..) + , hSetBuffering + ) +import System.Log.FastLogger ( defaultBufSize + , newStdoutLoggerSet + , toLogStr + ) import Yesod.Core -import Yesod.Core.Types hiding (Logger) +import Yesod.Core.Types hiding ( Logger ) import Yesod.Default.Config2 --- Import all relevant handler modules here. --- Don't forget to add new modules to your cabal file! +import Control.Arrow ( (***) ) +import Control.Lens +import Data.List ( lookup ) +import Database.Persist.Sql ( SqlBackend ) import Foundation import Handler.Apps import Handler.ErrorLogs import Handler.Icons -import Handler.Version import Handler.Marketplace +import Handler.Version +import Lib.PkgRepository ( watchPkgRepoRoot ) import Lib.Ssl +import Model +import Network.HTTP.Types.Header ( hOrigin ) +import Network.Wai.Middleware.RequestLogger.JSON import Settings +import System.Directory ( createDirectoryIfMissing ) import System.Posix.Process import System.Time.Extra -import Model -import Control.Lens -import Control.Arrow ((***)) -import Network.HTTP.Types.Header ( hOrigin ) -import Data.List (lookup) -import Network.Wai.Middleware.RequestLogger.JSON -import System.Directory (createDirectoryIfMissing) -import Database.Persist.Sql (SqlBackend) -import Yesod +import Yesod -- This line actually creates our YesodDispatch instance. It is the second half -- of the call to mkYesodData which occurs in Foundation.hs. Please see the @@ -83,35 +111,36 @@ makeFoundation :: AppSettings -> IO RegistryCtx makeFoundation appSettings = do -- Some basic initializations: HTTP connection manager, logger, and static -- subsite. - appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger + appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger appWebServerThreadId <- newEmptyMVar - appShouldRestartWeb <- newMVar False + appShouldRestartWeb <- newMVar False -- We need a log function to create a connection pool. We need a connection -- pool to create our foundation. And we need our foundation to get a -- logging function. To get out of this loop, we initially create a -- temporary foundation without a real connection pool, get a log function -- from there, and then create the real foundation. - let mkFoundation appConnPool = RegistryCtx {..} - -- The RegistryCtx {..} syntax is an example of record wild cards. For more - -- information, see: - -- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html - tempFoundation = mkFoundation $ panic "connPool forced in tempFoundation" + let mkFoundation appConnPool appStopFsNotify = RegistryCtx { .. } +-- The RegistryCtx {..} syntax is an example of record wild cards. For more +-- information, see: +-- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html + tempFoundation = + mkFoundation (panic "connPool forced in tempFoundation") (panic "stopFsNotify forced in tempFoundation") logFunc = messageLoggerSource tempFoundation appLogger + stop <- runLoggingT (runReaderT watchPkgRepoRoot appSettings) logFunc createDirectoryIfMissing True (errorLogRoot appSettings) -- Create the database connection pool - pool <- flip runLoggingT logFunc $ createPostgresqlPool - (pgConnStr $ appDatabaseConf appSettings) - (pgPoolSize . appDatabaseConf $ appSettings) + pool <- flip runLoggingT logFunc + $ createPostgresqlPool (pgConnStr $ appDatabaseConf appSettings) (pgPoolSize . appDatabaseConf $ appSettings) -- Preform database migration using application logging settings runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc -- Return the foundation - return $ mkFoundation pool + return $ mkFoundation pool stop -- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and -- applying some additional middlewares. @@ -189,14 +218,12 @@ dynamicCorsResourcePolicy req = Just . policy . lookup hOrigin $ requestHeaders } makeLogWare :: RegistryCtx -> IO Middleware -makeLogWare foundation = - mkRequestLogger def - { outputFormat = - if appDetailedRequestLogging $ appSettings foundation - then Detailed True - else CustomOutputFormatWithDetailsAndHeaders formatAsJSONWithHeaders - , destination = Logger $ loggerSet $ appLogger foundation - } +makeLogWare foundation = mkRequestLogger def + { outputFormat = if appDetailedRequestLogging $ appSettings foundation + then Detailed True + else CustomOutputFormatWithDetailsAndHeaders formatAsJSONWithHeaders + , destination = Logger $ loggerSet $ appLogger foundation + } makeAuthWare :: RegistryCtx -> Middleware makeAuthWare _ app req res = next @@ -229,10 +256,10 @@ appMain = do -- Get the settings from all relevant sources settings <- loadYamlSettingsArgs -- fall back to compile-time values, set to [] to require values at runtime - [configSettingsYmlValue] + [configSettingsYmlValue] -- allow environment variables to override - useEnv + useEnv -- Generate the foundation from the settings makeFoundation settings >>= startApp @@ -262,15 +289,14 @@ startWeb foundation = do app <- makeApplication foundation startWeb' app where - startWeb' app = do - let AppSettings{..} = appSettings foundation + startWeb' app = (`onException` (appStopFsNotify foundation)) $ do + let AppSettings {..} = appSettings foundation putStrLn @Text $ "Launching Tor Web Server on port " <> show torPort torAction <- async $ runSettings (warpSettings torPort foundation) app putStrLn @Text $ "Launching Web Server on port " <> show appPort action <- if sslAuto - then async $ runTLS (tlsSettings sslCertLocation sslKeyLocation) - (warpSettings appPort foundation) app - else async $ runSettings (warpSettings appPort foundation) app + then async $ runTLS (tlsSettings sslCertLocation sslKeyLocation) (warpSettings appPort foundation) app + else async $ runSettings (warpSettings appPort foundation) app let actions = (action, torAction) setWebProcessThreadId (join (***) asyncThreadId actions) foundation @@ -303,21 +329,21 @@ shutdownAll threadIds = do -- Careful, you should always spawn this within forkIO so as to avoid accidentally killing the running process shutdownWeb :: RegistryCtx -> IO () -shutdownWeb RegistryCtx{..} = do - threadIds <- takeMVar appWebServerThreadId +shutdownWeb RegistryCtx {..} = do + threadIds <- takeMVar appWebServerThreadId void $ both killThread threadIds -------------------------------------------------------------- -- Functions for DevelMain.hs (a way to run the RegistryCtx from GHCi) -------------------------------------------------------------- -getApplicationRepl :: IO (Int, RegistryCtx, Application) +getApplicationRepl :: IO (Int, RegistryCtx, Application) getApplicationRepl = do - settings <- getAppSettings + settings <- getAppSettings foundation <- getAppSettings >>= makeFoundation - wsettings <- getDevSettings $ warpSettings (appPort settings) foundation - app1 <- makeApplication foundation - return (getPort wsettings, foundation, app1) + wsettings <- getDevSettings $ warpSettings (appPort settings) foundation + app1 <- makeApplication foundation + return (getPort wsettings, foundation, app1) shutdownApp :: RegistryCtx -> IO () shutdownApp _ = return () @@ -325,10 +351,10 @@ shutdownApp _ = return () -- | For yesod devel, return the Warp settings and WAI Application. getApplicationDev :: AppPort -> IO (Settings, Application) getApplicationDev port = do - settings <- getAppSettings + settings <- getAppSettings foundation <- makeFoundation settings - app <- makeApplication foundation - wsettings <- getDevSettings $ warpSettings port foundation + app <- makeApplication foundation + wsettings <- getDevSettings $ warpSettings port foundation return (wsettings, app) -- | main function for use by yesod devel @@ -347,4 +373,4 @@ handler h = getAppSettings >>= makeFoundation >>= flip unsafeHandler h -- | Run DB queries db :: ReaderT SqlBackend (HandlerFor RegistryCtx) a -> IO a -db = handler . runDB \ No newline at end of file +db = handler . runDB diff --git a/src/Foundation.hs b/src/Foundation.hs index 7e7ebad..11a8f7e 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -15,8 +15,11 @@ import Yesod.Core import Yesod.Core.Types ( Logger ) import qualified Yesod.Core.Unsafe as Unsafe +import Control.Monad.Reader.Has ( Has(extract, update) ) +import Lib.PkgRepository import Lib.Types.AppIndex import Settings +import System.FilePath ( () ) import Yesod.Persist.Core -- | The foundation datatype for your application. This can be a good place to @@ -31,7 +34,17 @@ data RegistryCtx = RegistryCtx , appWebServerThreadId :: MVar (ThreadId, ThreadId) , appShouldRestartWeb :: MVar Bool , appConnPool :: ConnectionPool + , appStopFsNotify :: IO Bool } +instance Has PkgRepo RegistryCtx where + extract = do + liftA2 PkgRepo (( "apps") . resourcesDir . appSettings) (staticBinDir . appSettings) + update f ctx = + let repo = f $ extract ctx + settings = (appSettings ctx) { resourcesDir = pkgRepoFileRoot repo, staticBinDir = pkgRepoAppMgrBin repo } + in ctx { appSettings = settings } + + setWebProcessThreadId :: (ThreadId, ThreadId) -> RegistryCtx -> IO () setWebProcessThreadId tid a = putMVar (appWebServerThreadId a) $ tid diff --git a/src/Lib/External/AppMgr.hs b/src/Lib/External/AppMgr.hs index b650b27..2479a82 100644 --- a/src/Lib/External/AppMgr.hs +++ b/src/Lib/External/AppMgr.hs @@ -18,7 +18,6 @@ import System.Process.Typed hiding ( createPipe ) import Conduit ( (.|) , ConduitT - , MonadThrow , runConduit ) import qualified Data.Conduit.List as CL diff --git a/src/Lib/PkgRepository.hs b/src/Lib/PkgRepository.hs new file mode 100644 index 0000000..2b19cdf --- /dev/null +++ b/src/Lib/PkgRepository.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DataKinds #-} +module Lib.PkgRepository where + +import Conduit ( (.|) + , runConduit + , runResourceT + , sinkFileCautious + ) +import Control.Monad.Logger ( MonadLogger + , MonadLoggerIO + , logError + , logInfo + , logWarn + ) +import Control.Monad.Reader.Has ( Has + , ask + , asks + ) +import Data.Aeson ( eitherDecodeFileStrict' ) +import qualified Data.Attoparsec.Text as Atto +import Data.String.Interpolate.IsString + ( i ) +import qualified Data.Text as T +import qualified Lib.External.AppMgr as AppMgr +import Lib.Registry ( Extension(Extension) ) +import Lib.Types.AppIndex ( PkgId(PkgId) + , ServiceManifest(serviceManifestIcon) + ) +import Lib.Types.Emver ( Version + , parseVersion + ) +import Startlude ( ($) + , (&&) + , (.) + , (<$>) + , Bool(..) + , Either(Left, Right) + , Eq((==)) + , Exception + , FilePath + , IO + , MonadIO(liftIO) + , MonadReader + , Show + , String + , filter + , for_ + , fromMaybe + , not + , partitionEithers + , pure + , show + , throwIO + ) +import System.FSNotify ( Event(Added) + , eventPath + , watchTree + , withManager + ) +import System.FilePath ( (<.>) + , () + , takeBaseName + , takeDirectory + , takeExtension + , takeFileName + ) +import UnliftIO ( MonadUnliftIO + , askRunInIO + , async + , mapConcurrently + , newEmptyMVar + , onException + , takeMVar + , wait + ) +import UnliftIO ( tryPutMVar ) +import UnliftIO.Concurrent ( forkIO ) +import UnliftIO.Directory ( listDirectory + , removeFile + , renameFile + ) + +data ManifestParseException = ManifestParseException PkgId Version String + deriving Show +instance Exception ManifestParseException + +data PkgRepo = PkgRepo + { pkgRepoFileRoot :: FilePath + , pkgRepoAppMgrBin :: FilePath + } + +getVersionsFor :: (MonadIO m, MonadReader r m, Has PkgRepo r, MonadLogger m) => PkgId -> m [Version] +getVersionsFor pkg = do + root <- asks pkgRepoFileRoot + subdirs <- listDirectory $ root show pkg + let (failures, successes) = partitionEithers $ (Atto.parseOnly parseVersion . T.pack) <$> subdirs + for_ failures $ \f -> $logWarn [i|Emver Parse Failure for #{pkg}: #{f}|] + pure successes + +-- extract all package assets into their own respective files +extractPkg :: (MonadUnliftIO m, MonadReader r m, Has PkgRepo r, MonadLoggerIO m) => PkgId -> Version -> m () +extractPkg pkg v = (`onException` cleanup) $ do + $logInfo [i|Extracting package: #{pkg}@#{v}|] + PkgRepo { pkgRepoFileRoot = root, pkgRepoAppMgrBin = appmgr } <- ask + let s9pk = Extension @"s9pk" $ show pkg + let pkgRoot = root show pkg show v + manifestTask <- async $ liftIO . runResourceT $ AppMgr.sourceManifest appmgr root s9pk $ sinkIt + (pkgRoot "manifest.json") + instructionsTask <- async $ liftIO . runResourceT $ AppMgr.sourceInstructions appmgr root s9pk $ sinkIt + (pkgRoot "instructions.md") + licenseTask <- async $ liftIO . runResourceT $ AppMgr.sourceLicense appmgr root s9pk $ sinkIt + (pkgRoot "license.md") + iconTask <- async $ liftIO . runResourceT $ AppMgr.sourceIcon appmgr root s9pk $ sinkIt (pkgRoot "icon.tmp") + wait manifestTask + eManifest <- liftIO (eitherDecodeFileStrict' (pkgRoot "manifest.json")) + case eManifest of + Left e -> do + $logError [i|Invalid Package Manifest: #{pkg}@#{v}|] + liftIO . throwIO $ ManifestParseException pkg v e + Right manifest -> do + wait iconTask + let iconDest = "icon" <.> T.unpack (fromMaybe "png" (serviceManifestIcon manifest)) + liftIO $ renameFile (pkgRoot "icon.tmp") (pkgRoot iconDest) + wait instructionsTask + wait licenseTask + where + sinkIt fp source = runConduit $ source .| sinkFileCautious fp + cleanup = do + root <- asks pkgRepoFileRoot + let pkgRoot = root show pkg show v + fs <- listDirectory pkgRoot + let toRemove = filter (not . (== ".s9pk") . takeExtension) fs + mapConcurrently (removeFile . (pkgRoot )) toRemove + +watchPkgRepoRoot :: (MonadUnliftIO m, MonadReader r m, Has PkgRepo r, MonadLoggerIO m) => m (IO Bool) +watchPkgRepoRoot = do + root <- asks pkgRepoFileRoot + runInIO <- askRunInIO + box <- newEmptyMVar @_ @() + _ <- forkIO $ liftIO $ withManager $ \watchManager -> do + stop <- watchTree watchManager root onlyAdded $ \evt -> + let pkg = PkgId . T.pack $ takeBaseName (eventPath evt) + version = Atto.parseOnly parseVersion . T.pack . takeFileName . takeDirectory $ (eventPath evt) + in case version of + Left _ -> runInIO $ do + $logError [i|Invalid Version in package path: #{eventPath evt}|] + Right v -> runInIO (extractPkg pkg v) + takeMVar box + stop + pure $ tryPutMVar box () + where + onlyAdded = \case + Added path _ isDir -> not isDir && takeExtension path == ".s9pk" + _ -> False diff --git a/src/Settings.hs b/src/Settings.hs index f6b9ed8..41a6b24 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -1,5 +1,6 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MultiParamTypeClasses #-} -- | Settings are centralized, as much as possible, into this file. This -- includes database connection settings, static file locations, etc. -- In addition, you can configure a number of different aspects of Yesod @@ -23,6 +24,8 @@ import Network.Wai.Handler.Warp ( HostPreference ) import System.FilePath ( () ) import Yesod.Default.Config2 ( configSettingsYml ) +import Control.Monad.Reader.Has ( Has(extract, update) ) +import Lib.PkgRepository ( PkgRepo(PkgRepo, pkgRepoAppMgrBin, pkgRepoFileRoot) ) import Lib.Types.Emver import Orphans.Emver ( ) -- | Runtime settings to configure this application. These settings can be @@ -54,6 +57,11 @@ data AppSettings = AppSettings , staticBinDir :: FilePath , errorLogRoot :: FilePath } +instance Has PkgRepo AppSettings where + extract = liftA2 PkgRepo (( "apps") . resourcesDir) staticBinDir + update f r = + let repo = f $ extract r in r { resourcesDir = pkgRepoFileRoot repo, staticBinDir = pkgRepoAppMgrBin repo } + instance FromJSON AppSettings where parseJSON = withObject "AppSettings" $ \o -> do From cd4bc994cc599a5306cd238694a71d5c9cf29857 Mon Sep 17 00:00:00 2001 From: Lucy Cifferello <12953208+elvece@users.noreply.github.com> Date: Mon, 27 Sep 2021 18:11:38 -0600 Subject: [PATCH 26/48] sort versions --- src/Handler/Marketplace.hs | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/src/Handler/Marketplace.hs b/src/Handler/Marketplace.hs index 13d26d7..a7a0c35 100644 --- a/src/Handler/Marketplace.hs +++ b/src/Handler/Marketplace.hs @@ -276,9 +276,8 @@ getPackageListR = do query <- T.filter (not . isSpace) . 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 - $logInfo $ show packageMetadata + settings <- getsYesod appSettings + packageMetadata <- runDB $ fetchPackageMetadata serviceDetailResult <- liftIO $ mapConcurrently (getServiceDetails settings packageMetadata Nothing) filteredServices' let (_, services) = partitionEithers serviceDetailResult @@ -348,18 +347,17 @@ getServiceDetails settings metadata maybeVersion appId = do case eitherDecode $ manifest' of Left e -> pure $ Left $ "Could not parse service manifest for " <> show appId <> ": " <> show e Right m -> do - d <- liftIO $ mapConcurrently (mapDependencyMetadata domain metadata) - (HM.toList $ serviceManifestDependencies m) + d <- liftIO + $ mapConcurrently (mapDependencyMetadata domain metadata) (HM.toList $ serviceManifestDependencies m) pure $ Right $ ServiceRes { serviceResIcon = [i|https://#{domain}/package/icon/#{appId}|] , serviceResManifest = decode $ manifest' -- pass through raw JSON Value , serviceResCategories = snd packageMetadata , serviceResInstructions = [i|https://#{domain}/package/instructions/#{appId}|] , serviceResLicense = [i|https://#{domain}/package/license/#{appId}|] - , serviceResVersions = fst packageMetadata + , serviceResVersions = sortOn Down $ fst packageMetadata , serviceResDependencyInfo = HM.fromList $ snd $ partitionEithers d } - mapDependencyMetadata :: (MonadIO m) => Text -> HM.HashMap PkgId ([Version], [CategoryTitle]) From d51db922ca8315af5d48daac5a0a455e401ef830 Mon Sep 17 00:00:00 2001 From: Lucy Cifferello <12953208+elvece@users.noreply.github.com> Date: Mon, 27 Sep 2021 18:34:09 -0600 Subject: [PATCH 27/48] fix package path --- src/Lib/PkgRepository.hs | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/src/Lib/PkgRepository.hs b/src/Lib/PkgRepository.hs index 2b19cdf..fc56e91 100644 --- a/src/Lib/PkgRepository.hs +++ b/src/Lib/PkgRepository.hs @@ -110,13 +110,15 @@ extractPkg pkg v = (`onException` cleanup) $ do PkgRepo { pkgRepoFileRoot = root, pkgRepoAppMgrBin = appmgr } <- ask let s9pk = Extension @"s9pk" $ show pkg let pkgRoot = root show pkg show v - manifestTask <- async $ liftIO . runResourceT $ AppMgr.sourceManifest appmgr root s9pk $ sinkIt + $logInfo [i|#{s9pk}|] + $logInfo [i|#{pkgRoot}|] + manifestTask <- async $ liftIO . runResourceT $ AppMgr.sourceManifest appmgr pkgRoot s9pk $ sinkIt (pkgRoot "manifest.json") - instructionsTask <- async $ liftIO . runResourceT $ AppMgr.sourceInstructions appmgr root s9pk $ sinkIt + instructionsTask <- async $ liftIO . runResourceT $ AppMgr.sourceInstructions appmgr pkgRoot s9pk $ sinkIt (pkgRoot "instructions.md") - licenseTask <- async $ liftIO . runResourceT $ AppMgr.sourceLicense appmgr root s9pk $ sinkIt + licenseTask <- async $ liftIO . runResourceT $ AppMgr.sourceLicense appmgr pkgRoot s9pk $ sinkIt (pkgRoot "license.md") - iconTask <- async $ liftIO . runResourceT $ AppMgr.sourceIcon appmgr root s9pk $ sinkIt (pkgRoot "icon.tmp") + iconTask <- async $ liftIO . runResourceT $ AppMgr.sourceIcon appmgr pkgRoot s9pk $ sinkIt (pkgRoot "icon.tmp") wait manifestTask eManifest <- liftIO (eitherDecodeFileStrict' (pkgRoot "manifest.json")) case eManifest of From 42ac32bca4a1e3e1785ddc82f30a6ff39af2027b Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Mon, 27 Sep 2021 20:26:03 -0600 Subject: [PATCH 28/48] redefine appmgr calls, holes at call sites --- src/Handler/Apps.hs | 23 ++++---- src/Handler/Icons.hs | 109 +++++++++++++++++++------------------ src/Handler/Marketplace.hs | 69 +++++++++++------------ src/Lib/External/AppMgr.hs | 40 +++++++------- src/Lib/PkgRepository.hs | 13 ++--- 5 files changed, 128 insertions(+), 126 deletions(-) diff --git a/src/Handler/Apps.hs b/src/Handler/Apps.hs index 531cace..b2c401a 100644 --- a/src/Handler/Apps.hs +++ b/src/Handler/Apps.hs @@ -72,17 +72,18 @@ getSysR e = do getAppManifestR :: PkgId -> Handler TypedContent getAppManifestR appId = do - (appsDir, appMgrDir) <- getsYesod $ (( "apps") . resourcesDir &&& staticBinDir) . appSettings - av <- getVersionFromQuery appsDir appExt >>= \case - Nothing -> sendResponseStatus status404 ("Specified App Version Not Found" :: Text) - Just v -> pure v - let appDir = (<> "/") . ( show av) . ( show appId) $ appsDir - addPackageHeader appMgrDir appDir appExt - sourceManifest appMgrDir - appDir - appExt - (\bsSource -> respondSource "application/json" (bsSource .| awaitForever sendChunkBS)) - where appExt = Extension (show appId) :: Extension "s9pk" + -- (appsDir, appMgrDir) <- getsYesod $ (( "apps") . resourcesDir &&& staticBinDir) . appSettings + -- av <- getVersionFromQuery appsDir appExt >>= \case + -- Nothing -> sendResponseStatus status404 ("Specified App Version Not Found" :: Text) + -- Just v -> pure v + -- let appDir = (<> "/") . ( show av) . ( show appId) $ appsDir + -- addPackageHeader appMgrDir appDir appExt + -- sourceManifest appMgrDir + -- appDir + -- appExt + -- (\bsSource -> respondSource "application/json" (bsSource .| awaitForever sendChunkBS)) + -- where appExt = Extension (show appId) :: Extension "s9pk" + _ getAppR :: Extension "s9pk" -> Handler TypedContent getAppR e = do diff --git a/src/Handler/Icons.hs b/src/Handler/Icons.hs index 5fed13b..6ba81cf 100644 --- a/src/Handler/Icons.hs +++ b/src/Handler/Icons.hs @@ -39,62 +39,65 @@ ixt = toS $ toUpper <$> drop 1 ".png" getIconsR :: PkgId -> Handler TypedContent getIconsR appId = do - (appsDir, appMgrDir) <- getsYesod $ (( "apps") . resourcesDir &&& staticBinDir) . appSettings - spec <- getVersionFromQuery appsDir ext >>= \case - Nothing -> sendResponseStatus status404 ("Specified App Version Not Found" :: Text) - Just v -> pure v - let appDir = (<> "/") . ( show spec) . ( show appId) $ appsDir - manifest' <- sourceManifest appMgrDir appDir ext (\bsSource -> runConduit $ bsSource .| CL.foldMap BS.fromStrict) - manifest <- case eitherDecode manifest' of - Left e -> do - $logError "could not parse service manifest!" - $logError (show e) - sendResponseStatus status500 ("Internal Server Error" :: Text) - Right a -> pure a - mimeType <- case serviceManifestIcon manifest of - Nothing -> pure typePng - Just a -> do - let (_, iconExt) = splitExtension $ toS a - let x = toUpper <$> drop 1 iconExt - case readMaybe $ toS x of - Nothing -> do - $logInfo $ "unknown icon extension type: " <> show x <> ". Sending back typePlain." - pure typePlain - Just iconType -> case iconType of - PNG -> pure typePng - SVG -> pure typeSvg - JPG -> pure typeJpeg - JPEG -> pure typeJpeg - sourceIcon appMgrDir - (appDir show ext) - ext - (\bsSource -> respondSource mimeType (bsSource .| awaitForever sendChunkBS)) - where ext = Extension (show appId) :: Extension "s9pk" + -- (appsDir, appMgrDir) <- getsYesod $ (( "apps") . resourcesDir &&& staticBinDir) . appSettings + -- spec <- getVersionFromQuery appsDir ext >>= \case + -- Nothing -> sendResponseStatus status404 ("Specified App Version Not Found" :: Text) + -- Just v -> pure v + -- let appDir = (<> "/") . ( show spec) . ( show appId) $ appsDir + -- manifest' <- sourceManifest appMgrDir appDir ext (\bsSource -> runConduit $ bsSource .| CL.foldMap BS.fromStrict) + -- manifest <- case eitherDecode manifest' of + -- Left e -> do + -- $logError "could not parse service manifest!" + -- $logError (show e) + -- sendResponseStatus status500 ("Internal Server Error" :: Text) + -- Right a -> pure a + -- mimeType <- case serviceManifestIcon manifest of + -- Nothing -> pure typePng + -- Just a -> do + -- let (_, iconExt) = splitExtension $ toS a + -- let x = toUpper <$> drop 1 iconExt + -- case readMaybe $ toS x of + -- Nothing -> do + -- $logInfo $ "unknown icon extension type: " <> show x <> ". Sending back typePlain." + -- pure typePlain + -- Just iconType -> case iconType of + -- PNG -> pure typePng + -- SVG -> pure typeSvg + -- JPG -> pure typeJpeg + -- JPEG -> pure typeJpeg + -- sourceIcon appMgrDir + -- (appDir show ext) + -- ext + -- (\bsSource -> respondSource mimeType (bsSource .| awaitForever sendChunkBS)) + -- where ext = Extension (show appId) :: Extension "s9pk" + _ getLicenseR :: PkgId -> Handler TypedContent getLicenseR appId = do - (appsDir, appMgrDir) <- getsYesod $ (( "apps") . resourcesDir &&& staticBinDir) . appSettings - spec <- getVersionFromQuery appsDir ext >>= \case - Nothing -> sendResponseStatus status404 ("Specified App Version Not Found" :: Text) - Just v -> pure v - servicePath <- liftIO $ getVersionedFileFromDir appsDir ext spec - case servicePath of - Nothing -> notFound - Just p -> - sourceLicense appMgrDir p ext (\bsSource -> respondSource typePlain (bsSource .| awaitForever sendChunkBS)) - where ext = Extension (show appId) :: Extension "s9pk" + -- (appsDir, appMgrDir) <- getsYesod $ (( "apps") . resourcesDir &&& staticBinDir) . appSettings + -- spec <- getVersionFromQuery appsDir ext >>= \case + -- Nothing -> sendResponseStatus status404 ("Specified App Version Not Found" :: Text) + -- Just v -> pure v + -- servicePath <- liftIO $ getVersionedFileFromDir appsDir ext spec + -- case servicePath of + -- Nothing -> notFound + -- Just p -> + -- sourceLicense appMgrDir p ext (\bsSource -> respondSource typePlain (bsSource .| awaitForever sendChunkBS)) + -- where ext = Extension (show appId) :: Extension "s9pk" + _ getInstructionsR :: PkgId -> Handler TypedContent getInstructionsR appId = do - (appsDir, appMgrDir) <- getsYesod $ (( "apps") . resourcesDir &&& staticBinDir) . appSettings - spec <- getVersionFromQuery appsDir ext >>= \case - Nothing -> sendResponseStatus status404 ("Specified App Version Not Found" :: Text) - Just v -> pure v - servicePath <- liftIO $ getVersionedFileFromDir appsDir ext spec - case servicePath of - Nothing -> notFound - Just p -> sourceInstructions appMgrDir - p - ext - (\bsSource -> respondSource typePlain (bsSource .| awaitForever sendChunkBS)) - where ext = Extension (show appId) :: Extension "s9pk" + -- (appsDir, appMgrDir) <- getsYesod $ (( "apps") . resourcesDir &&& staticBinDir) . appSettings + -- spec <- getVersionFromQuery appsDir ext >>= \case + -- Nothing -> sendResponseStatus status404 ("Specified App Version Not Found" :: Text) + -- Just v -> pure v + -- servicePath <- liftIO $ getVersionedFileFromDir appsDir ext spec + -- case servicePath of + -- Nothing -> notFound + -- Just p -> sourceInstructions appMgrDir + -- p + -- ext + -- (\bsSource -> respondSource typePlain (bsSource .| awaitForever sendChunkBS)) + -- where ext = Extension (show appId) :: Extension "s9pk" + _ diff --git a/src/Handler/Marketplace.hs b/src/Handler/Marketplace.hs index a7a0c35..7c04156 100644 --- a/src/Handler/Marketplace.hs +++ b/src/Handler/Marketplace.hs @@ -329,34 +329,35 @@ getServiceDetails :: (MonadUnliftIO m, Monad m, MonadError IOException m) -> PkgId -> m (Either Text ServiceRes) getServiceDetails settings metadata maybeVersion appId = do - packageMetadata <- case HM.lookup appId metadata of - Nothing -> throwIO $ NotFoundE [i|#{appId} not found.|] - Just m -> pure m - let (appsDir, appMgrDir) = (( "apps") . resourcesDir &&& staticBinDir) settings - let domain = registryHostname settings - version <- case maybeVersion of - Nothing -> do - -- grab first value, which will be the latest version - case fst packageMetadata of - [] -> throwIO $ NotFoundE $ "no latest version found for " <> show appId - x : _ -> pure x - Just v -> pure v - let appDir = (<> "/") . ( show version) . ( show appId) $ appsDir - let appExt = Extension (show appId) :: Extension "s9pk" - manifest' <- sourceManifest appMgrDir appDir appExt (\bs -> sinkMem (bs .| mapC BS.fromStrict)) - case eitherDecode $ manifest' of - Left e -> pure $ Left $ "Could not parse service manifest for " <> show appId <> ": " <> show e - Right m -> do - d <- liftIO - $ mapConcurrently (mapDependencyMetadata domain metadata) (HM.toList $ serviceManifestDependencies m) - pure $ Right $ ServiceRes { serviceResIcon = [i|https://#{domain}/package/icon/#{appId}|] - , serviceResManifest = decode $ manifest' -- pass through raw JSON Value - , serviceResCategories = snd packageMetadata - , serviceResInstructions = [i|https://#{domain}/package/instructions/#{appId}|] - , serviceResLicense = [i|https://#{domain}/package/license/#{appId}|] - , serviceResVersions = sortOn Down $ fst packageMetadata - , serviceResDependencyInfo = HM.fromList $ snd $ partitionEithers d - } + -- packageMetadata <- case HM.lookup appId metadata of + -- Nothing -> throwIO $ NotFoundE [i|#{appId} not found.|] + -- Just m -> pure m + -- let (appsDir, appMgrDir) = (( "apps") . resourcesDir &&& staticBinDir) settings + -- let domain = registryHostname settings + -- version <- case maybeVersion of + -- Nothing -> do + -- -- grab first value, which will be the latest version + -- case fst packageMetadata of + -- [] -> throwIO $ NotFoundE $ "no latest version found for " <> show appId + -- x : _ -> pure x + -- Just v -> pure v + -- let appDir = (<> "/") . ( show version) . ( show appId) $ appsDir + -- let appExt = Extension (show appId) :: Extension "s9pk" + -- manifest' <- sourceManifest appMgrDir appDir appExt (\bs -> sinkMem (bs .| mapC BS.fromStrict)) + -- case eitherDecode $ manifest' of + -- Left e -> pure $ Left $ "Could not parse service manifest for " <> show appId <> ": " <> show e + -- Right m -> do + -- d <- liftIO $ mapConcurrently (mapDependencyMetadata domain metadata) + -- (HM.toList $ serviceManifestDependencies m) + -- pure $ Right $ ServiceRes { serviceResIcon = [i|https://#{domain}/package/icon/#{appId}|] + -- , serviceResManifest = decode $ manifest' -- pass through raw JSON Value + -- , serviceResCategories = snd packageMetadata + -- , serviceResInstructions = [i|https://#{domain}/package/instructions/#{appId}|] + -- , serviceResLicense = [i|https://#{domain}/package/license/#{appId}|] + -- , serviceResVersions = fst packageMetadata + -- , serviceResDependencyInfo = HM.fromList $ snd $ partitionEithers d + -- } + _ mapDependencyMetadata :: (MonadIO m) => Text @@ -380,13 +381,13 @@ mapDependencyMetadata domain metadata (appId, depInfo) = do } ) -decodeInstructions :: (MonadUnliftIO m, MonadHandler m, MonadThrow m) => FilePath -> FilePath -> S9PK -> m Text -decodeInstructions appmgrPath depPath package = do - sourceInstructions appmgrPath depPath package (\bs -> sinkMem (bs .| CT.decode CT.utf8)) +-- decodeInstructions :: (MonadUnliftIO m, MonadHandler m, MonadThrow m) => FilePath -> FilePath -> S9PK -> m Text +-- decodeInstructions appmgrPath depPath package = do +-- sourceInstructions appmgrPath depPath package (\bs -> sinkMem (bs .| CT.decode CT.utf8)) -decodeLicense :: (MonadUnliftIO m, MonadThrow m, MonadHandler m) => FilePath -> FilePath -> S9PK -> m Text -decodeLicense appmgrPath depPath package = - sourceLicense appmgrPath depPath package (\bs -> sinkMem (bs .| CT.decode CT.utf8)) +-- decodeLicense :: (MonadUnliftIO m, MonadThrow m, MonadHandler m) => FilePath -> FilePath -> S9PK -> m Text +-- decodeLicense appmgrPath depPath package = +-- sourceLicense appmgrPath depPath package (\bs -> sinkMem (bs .| CT.decode CT.utf8)) fetchAllAppVersions :: Key SApp -> HandlerFor RegistryCtx ([VersionInfo], ReleaseNotes) fetchAllAppVersions appId = do diff --git a/src/Lib/External/AppMgr.hs b/src/Lib/External/AppMgr.hs index 2479a82..70a6ab0 100644 --- a/src/Lib/External/AppMgr.hs +++ b/src/Lib/External/AppMgr.hs @@ -56,31 +56,31 @@ readProcessInheritStderr a b c sink = do $ System.Process.Typed.proc a b withProcessTerm_ pc $ \p -> sink (getStdout p) -sourceManifest :: (MonadUnliftIO m) => FilePath -> FilePath -> S9PK -> (ConduitT () ByteString m () -> m r) -> m r -sourceManifest appmgrPath appPath e@(Extension appId) sink = do - let appmgr = readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "manifest", appPath show e] "" - appmgr sink `catch` \ece -> throwIO (AppMgrE [i|embassy-sdk inspect manifest #{appId}|] (eceExitCode ece)) +sourceManifest :: (MonadUnliftIO m) => FilePath -> FilePath -> (ConduitT () ByteString m () -> m r) -> m r +sourceManifest appmgrPath pkgFile sink = do + let appmgr = readProcessInheritStderr (appmgrPath "embassy-sdk") ["inspect", "manifest", pkgFile] "" + appmgr sink `catch` \ece -> throwIO (AppMgrE [i|embassy-sdk inspect manifest #{pkgFile}|] (eceExitCode ece)) -sourceIcon :: (MonadUnliftIO m) => FilePath -> FilePath -> S9PK -> (ConduitT () ByteString m () -> m r) -> m r -sourceIcon appmgrPath appPath (Extension icon) sink = do - let appmgr = readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "icon", appPath] "" - appmgr sink `catch` \ece -> throwIO $ AppMgrE [i|embassy-sdk inspect icon #{icon}|] (eceExitCode ece) +sourceIcon :: (MonadUnliftIO m) => FilePath -> FilePath -> (ConduitT () ByteString m () -> m r) -> m r +sourceIcon appmgrPath pkgFile sink = do + let appmgr = readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "icon", pkgFile] "" + appmgr sink `catch` \ece -> throwIO $ AppMgrE [i|embassy-sdk inspect icon #{pkgFile}|] (eceExitCode ece) -getPackageHash :: (MonadUnliftIO m) => FilePath -> FilePath -> S9PK -> m ByteString -getPackageHash appmgrPath appPath e@(Extension appId) = do - let appmgr = readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "hash", appPath <> show e] "" +getPackageHash :: (MonadUnliftIO m) => FilePath -> FilePath -> m ByteString +getPackageHash appmgrPath pkgFile = do + let appmgr = readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "hash", pkgFile] "" appmgr (\bsSource -> runConduit $ bsSource .| CL.foldMap id) - `catch` \ece -> throwIO $ AppMgrE [i|embassy-sdk inspect hash #{appId}|] (eceExitCode ece) + `catch` \ece -> throwIO $ AppMgrE [i|embassy-sdk inspect hash #{pkgFile}|] (eceExitCode ece) -sourceInstructions :: (MonadUnliftIO m) => FilePath -> FilePath -> S9PK -> (ConduitT () ByteString m () -> m r) -> m r -sourceInstructions appmgrPath appPath (Extension appId) sink = do - let appmgr = readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "instructions", appPath] "" - appmgr sink `catch` \ece -> throwIO $ AppMgrE [i|embassy-sdk inspect instructions #{appId}|] (eceExitCode ece) +sourceInstructions :: (MonadUnliftIO m) => FilePath -> FilePath -> (ConduitT () ByteString m () -> m r) -> m r +sourceInstructions appmgrPath pkgFile sink = do + let appmgr = readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "instructions", pkgFile] "" + appmgr sink `catch` \ece -> throwIO $ AppMgrE [i|embassy-sdk inspect instructions #{pkgFile}|] (eceExitCode ece) -sourceLicense :: (MonadUnliftIO m) => FilePath -> FilePath -> S9PK -> (ConduitT () ByteString m () -> m r) -> m r -sourceLicense appmgrPath appPath (Extension appId) sink = do - let appmgr = readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "license", appPath] "" - appmgr sink `catch` \ece -> throwIO $ AppMgrE [i|embassy-sdk inspect license #{appId}|] (eceExitCode ece) +sourceLicense :: (MonadUnliftIO m) => FilePath -> FilePath -> (ConduitT () ByteString m () -> m r) -> m r +sourceLicense appmgrPath pkgFile sink = do + let appmgr = readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "license", pkgFile] "" + appmgr sink `catch` \ece -> throwIO $ AppMgrE [i|embassy-sdk inspect license #{pkgFile}|] (eceExitCode ece) sinkMem :: (Monad m, Monoid a) => ConduitT () a m () -> m a sinkMem c = runConduit $ c .| CL.foldMap id diff --git a/src/Lib/PkgRepository.hs b/src/Lib/PkgRepository.hs index fc56e91..7ec9b0d 100644 --- a/src/Lib/PkgRepository.hs +++ b/src/Lib/PkgRepository.hs @@ -108,17 +108,14 @@ extractPkg :: (MonadUnliftIO m, MonadReader r m, Has PkgRepo r, MonadLoggerIO m) extractPkg pkg v = (`onException` cleanup) $ do $logInfo [i|Extracting package: #{pkg}@#{v}|] PkgRepo { pkgRepoFileRoot = root, pkgRepoAppMgrBin = appmgr } <- ask - let s9pk = Extension @"s9pk" $ show pkg let pkgRoot = root show pkg show v - $logInfo [i|#{s9pk}|] - $logInfo [i|#{pkgRoot}|] - manifestTask <- async $ liftIO . runResourceT $ AppMgr.sourceManifest appmgr pkgRoot s9pk $ sinkIt + let s9pk = pkgRoot show pkg <.> "s9pk" + manifestTask <- async $ liftIO . runResourceT $ AppMgr.sourceManifest appmgr s9pk $ sinkIt (pkgRoot "manifest.json") - instructionsTask <- async $ liftIO . runResourceT $ AppMgr.sourceInstructions appmgr pkgRoot s9pk $ sinkIt + instructionsTask <- async $ liftIO . runResourceT $ AppMgr.sourceInstructions appmgr s9pk $ sinkIt (pkgRoot "instructions.md") - licenseTask <- async $ liftIO . runResourceT $ AppMgr.sourceLicense appmgr pkgRoot s9pk $ sinkIt - (pkgRoot "license.md") - iconTask <- async $ liftIO . runResourceT $ AppMgr.sourceIcon appmgr pkgRoot s9pk $ sinkIt (pkgRoot "icon.tmp") + licenseTask <- async $ liftIO . runResourceT $ AppMgr.sourceLicense appmgr s9pk $ sinkIt (pkgRoot "license.md") + iconTask <- async $ liftIO . runResourceT $ AppMgr.sourceIcon appmgr s9pk $ sinkIt (pkgRoot "icon.tmp") wait manifestTask eManifest <- liftIO (eitherDecodeFileStrict' (pkgRoot "manifest.json")) case eManifest of From e615abee4e8d9ff871afa8fcfa891360a5361684 Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Mon, 27 Sep 2021 20:35:42 -0600 Subject: [PATCH 29/48] remove unnecessary conversions --- src/Lib/PkgRepository.hs | 42 ++++++++++++++++++---------------------- 1 file changed, 19 insertions(+), 23 deletions(-) diff --git a/src/Lib/PkgRepository.hs b/src/Lib/PkgRepository.hs index 7ec9b0d..d43d2ca 100644 --- a/src/Lib/PkgRepository.hs +++ b/src/Lib/PkgRepository.hs @@ -5,6 +5,7 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DataKinds #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} module Lib.PkgRepository where import Conduit ( (.|) @@ -86,7 +87,7 @@ import UnliftIO.Directory ( listDirectory , renameFile ) -data ManifestParseException = ManifestParseException PkgId Version String +data ManifestParseException = ManifestParseException FilePath deriving Show instance Exception ManifestParseException @@ -104,24 +105,24 @@ getVersionsFor pkg = do pure successes -- extract all package assets into their own respective files -extractPkg :: (MonadUnliftIO m, MonadReader r m, Has PkgRepo r, MonadLoggerIO m) => PkgId -> Version -> m () -extractPkg pkg v = (`onException` cleanup) $ do - $logInfo [i|Extracting package: #{pkg}@#{v}|] - PkgRepo { pkgRepoFileRoot = root, pkgRepoAppMgrBin = appmgr } <- ask - let pkgRoot = root show pkg show v - let s9pk = pkgRoot show pkg <.> "s9pk" - manifestTask <- async $ liftIO . runResourceT $ AppMgr.sourceManifest appmgr s9pk $ sinkIt +extractPkg :: (MonadUnliftIO m, MonadReader r m, Has PkgRepo r, MonadLoggerIO m) => FilePath -> m () +extractPkg fp = (`onException` cleanup) $ do + $logInfo [i|Extracting package: #{fp}|] + PkgRepo { pkgRepoAppMgrBin = appmgr } <- ask + let pkgRoot = takeDirectory fp + -- let s9pk = pkgRoot show pkg <.> "s9pk" + manifestTask <- async $ liftIO . runResourceT $ AppMgr.sourceManifest appmgr fp $ sinkIt (pkgRoot "manifest.json") - instructionsTask <- async $ liftIO . runResourceT $ AppMgr.sourceInstructions appmgr s9pk $ sinkIt + instructionsTask <- async $ liftIO . runResourceT $ AppMgr.sourceInstructions appmgr fp $ sinkIt (pkgRoot "instructions.md") - licenseTask <- async $ liftIO . runResourceT $ AppMgr.sourceLicense appmgr s9pk $ sinkIt (pkgRoot "license.md") - iconTask <- async $ liftIO . runResourceT $ AppMgr.sourceIcon appmgr s9pk $ sinkIt (pkgRoot "icon.tmp") + licenseTask <- async $ liftIO . runResourceT $ AppMgr.sourceLicense appmgr fp $ sinkIt (pkgRoot "license.md") + iconTask <- async $ liftIO . runResourceT $ AppMgr.sourceIcon appmgr fp $ sinkIt (pkgRoot "icon.tmp") wait manifestTask eManifest <- liftIO (eitherDecodeFileStrict' (pkgRoot "manifest.json")) case eManifest of - Left e -> do - $logError [i|Invalid Package Manifest: #{pkg}@#{v}|] - liftIO . throwIO $ ManifestParseException pkg v e + Left _ -> do + $logError [i|Invalid Package Manifest: #{fp}|] + liftIO . throwIO $ ManifestParseException (pkgRoot "manifest.json") Right manifest -> do wait iconTask let iconDest = "icon" <.> T.unpack (fromMaybe "png" (serviceManifestIcon manifest)) @@ -131,8 +132,7 @@ extractPkg pkg v = (`onException` cleanup) $ do where sinkIt fp source = runConduit $ source .| sinkFileCautious fp cleanup = do - root <- asks pkgRepoFileRoot - let pkgRoot = root show pkg show v + let pkgRoot = takeDirectory fp fs <- listDirectory pkgRoot let toRemove = filter (not . (== ".s9pk") . takeExtension) fs mapConcurrently (removeFile . (pkgRoot )) toRemove @@ -143,13 +143,9 @@ watchPkgRepoRoot = do runInIO <- askRunInIO box <- newEmptyMVar @_ @() _ <- forkIO $ liftIO $ withManager $ \watchManager -> do - stop <- watchTree watchManager root onlyAdded $ \evt -> - let pkg = PkgId . T.pack $ takeBaseName (eventPath evt) - version = Atto.parseOnly parseVersion . T.pack . takeFileName . takeDirectory $ (eventPath evt) - in case version of - Left _ -> runInIO $ do - $logError [i|Invalid Version in package path: #{eventPath evt}|] - Right v -> runInIO (extractPkg pkg v) + stop <- watchTree watchManager root onlyAdded $ \evt -> do + let pkg = eventPath evt + runInIO (extractPkg pkg) takeMVar box stop pure $ tryPutMVar box () From 95086bcc2cb50243ca567cb7bb73a809f2f9ea2d Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Tue, 28 Sep 2021 10:00:09 -0600 Subject: [PATCH 30/48] add asset retrievers --- src/Lib/PkgRepository.hs | 59 +++++++++++++++++++++++++++++++++++++--- 1 file changed, 55 insertions(+), 4 deletions(-) diff --git a/src/Lib/PkgRepository.hs b/src/Lib/PkgRepository.hs index d43d2ca..1c83329 100644 --- a/src/Lib/PkgRepository.hs +++ b/src/Lib/PkgRepository.hs @@ -9,9 +9,12 @@ module Lib.PkgRepository where import Conduit ( (.|) + , ConduitT + , MonadResource , runConduit , runResourceT , sinkFileCautious + , sourceFile ) import Control.Monad.Logger ( MonadLogger , MonadLoggerIO @@ -28,9 +31,9 @@ import qualified Data.Attoparsec.Text as Atto import Data.String.Interpolate.IsString ( i ) import qualified Data.Text as T +import Lib.Error ( S9Error(NotFoundE) ) import qualified Lib.External.AppMgr as AppMgr -import Lib.Registry ( Extension(Extension) ) -import Lib.Types.AppIndex ( PkgId(PkgId) +import Lib.Types.AppIndex ( PkgId(..) , ServiceManifest(serviceManifestIcon) ) import Lib.Types.Emver ( Version @@ -40,17 +43,20 @@ import Startlude ( ($) , (&&) , (.) , (<$>) + , (<>) , Bool(..) + , ByteString , Either(Left, Right) , Eq((==)) , Exception , FilePath , IO + , Maybe(Just, Nothing) , MonadIO(liftIO) , MonadReader , Show - , String , filter + , find , for_ , fromMaybe , not @@ -69,7 +75,6 @@ import System.FilePath ( (<.>) , takeBaseName , takeDirectory , takeExtension - , takeFileName ) import UnliftIO ( MonadUnliftIO , askRunInIO @@ -86,6 +91,13 @@ import UnliftIO.Directory ( listDirectory , removeFile , renameFile ) +import Yesod.Core.Content ( typeGif + , typeJpeg + , typePlain + , typePng + , typeSvg + ) +import Yesod.Core.Types ( ContentType ) data ManifestParseException = ManifestParseException FilePath deriving Show @@ -145,6 +157,7 @@ watchPkgRepoRoot = do _ <- forkIO $ liftIO $ withManager $ \watchManager -> 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. runInIO (extractPkg pkg) takeMVar box stop @@ -153,3 +166,41 @@ watchPkgRepoRoot = do onlyAdded = \case Added path _ isDir -> not isDir && takeExtension path == ".s9pk" _ -> False + +getManifest :: (MonadResource m, MonadReader r m, Has PkgRepo r) => PkgId -> Version -> ConduitT () ByteString m () +getManifest pkg version = do + root <- asks pkgRepoFileRoot + let manifestPath = root show pkg show version "manifest.json" + sourceFile manifestPath + +getInstructions :: (MonadResource m, MonadReader r m, Has PkgRepo r) => PkgId -> Version -> ConduitT () ByteString m () +getInstructions pkg version = do + root <- asks pkgRepoFileRoot + let instructionsPath = root show pkg show version "instructions.md" + sourceFile instructionsPath + +getLicense :: (MonadResource m, MonadReader r m, Has PkgRepo r) => PkgId -> Version -> ConduitT () ByteString m () +getLicense pkg version = do + root <- asks pkgRepoFileRoot + let licensePath = root show pkg show version "license.md" + sourceFile licensePath + +getIcon :: (MonadResource m, MonadReader r m, Has PkgRepo r) + => PkgId + -> Version + -> m (ContentType, ConduitT () ByteString m ()) +getIcon pkg version = do + root <- asks pkgRepoFileRoot + let pkgRoot = root show pkg show version + mIconFile <- find ((== "icon") . takeBaseName) <$> listDirectory pkgRoot + case mIconFile of + Nothing -> throwIO $ NotFoundE $ show pkg <> ": Icon" + Just x -> do + let ct = case takeExtension x of + ".png" -> typePng + ".jpg" -> typeJpeg + ".jpeg" -> typeJpeg + ".svg" -> typeSvg + ".gif" -> typeGif + _ -> typePlain + pure $ (ct, sourceFile (pkgRoot x)) From 50ecce1c2187b0547b21b47695546f6e08a1254c Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Tue, 28 Sep 2021 15:43:56 -0600 Subject: [PATCH 31/48] builds --- config/routes | 10 +- src/Foundation.hs | 14 ++- src/Handler/Apps.hs | 153 ++++++++++++------------ src/Handler/Icons.hs | 100 +++++----------- src/Handler/Marketplace.hs | 228 +++++++++++++++++++----------------- src/Handler/Types/Status.hs | 22 +--- src/Handler/Version.hs | 65 +++++----- src/Lib/Error.hs | 16 ++- src/Lib/External/AppMgr.hs | 1 - src/Lib/PkgRepository.hs | 69 +++++++++-- src/Lib/Types/Emver.hs | 17 ++- src/Util/Function.hs | 3 + src/Util/Shared.hs | 39 +++--- 13 files changed, 377 insertions(+), 360 deletions(-) diff --git a/config/routes b/config/routes index d87e1be..eaa6d1d 100644 --- a/config/routes +++ b/config/routes @@ -2,18 +2,14 @@ /package/data CategoriesR GET -- get all marketplace categories /package/index PackageListR GET -- filter marketplace services by various query params -- /package/updates -/eos/latest EosR GET -- get eos information +/eos/latest EosVersionR GET -- get eos information +/eos/eos.img EosR GET -- get eos.img /latest-version VersionLatestR GET -- get latest version of apps in query param id /package/manifest/#PkgId AppManifestR GET -- get app manifest from appmgr -- ?version={semver-spec} /package/release-notes ReleaseNotesR GET -- get release notes for package - expects query param of id= /package/icon/#PkgId IconsR GET -- get icons - can specify version with ?spec= /package/license/#PkgId LicenseR GET -- get icons - can specify version with ?spec= /package/instructions/#PkgId InstructionsR GET -- get icons - can specify version with ?spec= - --- TODO confirm needed -/package/version/#Text VersionAppR GET -- get most recent appId version -!/sys/#SYS_EXTENSIONLESS SysR GET -- get most recent sys app -- ?spec={semver-spec} -/version VersionR GET -/sys/version/#Text VersionSysR GET -- get most recent sys app version +/package/version/#PkgId PkgVersionR GET -- get most recent appId version /error-logs ErrorLogsR POST \ No newline at end of file diff --git a/src/Foundation.hs b/src/Foundation.hs index 11a8f7e..33e586e 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -9,10 +9,13 @@ module Foundation where import Startlude hiding ( Handler ) import Control.Monad.Logger ( LogSource ) -import Database.Persist.Sql +import Database.Persist.Sql hiding ( update ) import Lib.Registry import Yesod.Core -import Yesod.Core.Types ( Logger ) +import Yesod.Core.Types ( HandlerData(handlerEnv) + , Logger + , RunHandlerEnv(rheChild, rheSite) + ) import qualified Yesod.Core.Unsafe as Unsafe import Control.Monad.Reader.Has ( Has(extract, update) ) @@ -43,6 +46,13 @@ 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 + 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 } + diff --git a/src/Handler/Apps.hs b/src/Handler/Apps.hs index b2c401a..bfec546 100644 --- a/src/Handler/Apps.hs +++ b/src/Handler/Apps.hs @@ -11,36 +11,64 @@ module Handler.Apps where import Startlude hiding ( Handler ) -import Control.Monad.Logger -import Data.Aeson +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 Data.Conduit import qualified Data.Conduit.Binary as CB import qualified Data.Text as T -import Database.Persist +import Database.Persist ( Entity(entityKey) ) import qualified GHC.Show ( Show(..) ) -import Network.HTTP.Types -import System.Directory +import Network.HTTP.Types ( status404 ) import System.FilePath ( (<.>) - , () + , takeBaseName ) import System.Posix.Files ( fileSize , getFileStatus ) -import Yesod.Core -import Yesod.Persist.Core +import Yesod.Core ( MonadHandler(HandlerSite) + , TypedContent + , addHeader + , getYesod + , notFound + , respondSource + , sendChunkBS + , sendResponseStatus + , typeJson + , typeOctet + , waiRequest + ) +import Yesod.Persist.Core ( YesodPersist(runDB) ) -import Database.Queries -import Foundation -import Lib.External.AppMgr -import Lib.Registry -import Lib.Types.AppIndex -import Lib.Types.Emver -import Lib.Types.FileSystem +import Conduit ( (.|) + , awaitForever + ) +import Data.String.Interpolate.IsString + ( i ) +import Database.Queries ( createMetric + , fetchApp + , fetchAppVersion + ) +import Foundation ( Handler ) +import Lib.Error ( S9Error(NotFoundE) ) +import Lib.PkgRepository ( getBestVersion + , getManifest + , getPackage + ) +import Lib.Registry ( S9PK ) +import Lib.Types.AppIndex ( PkgId(PkgId) ) +import Lib.Types.Emver ( Version + , parseVersion + ) import Network.Wai ( Request(requestHeaderUserAgent) ) -import Settings -import Util.Shared +import Util.Shared ( addPackageHeader + , getVersionSpecFromQuery + , orThrow + ) pureLog :: Show a => a -> Handler a pureLog = liftA2 (*>) ($logInfo . show) pure @@ -48,6 +76,11 @@ pureLog = liftA2 (*>) ($logInfo . show) pure logRet :: ToJSON a => Handler a -> Handler a logRet = (>>= liftA2 (*>) ($logInfo . decodeUtf8 . BS.toStrict . encode) pure) +inject :: MonadHandler m => ReaderT (HandlerSite m) m a -> m a +inject action = do + env <- getYesod + runReaderT action env + data FileExtension = FileExtension FilePath (Maybe String) instance Show FileExtension where show (FileExtension f Nothing ) = f @@ -64,76 +97,40 @@ getEmbassyOsVersion = userAgentOsVersion userAgentOsVersion = (hush . Atto.parseOnly userAgentOsVersionParser . decodeUtf8 <=< requestHeaderUserAgent) <$> waiRequest -getSysR :: Extension "" -> Handler TypedContent -getSysR e = do - sysResourceDir <- ( "sys") . resourcesDir . appSettings <$> getYesod - -- @TODO update with new response type here - getApp sysResourceDir e - getAppManifestR :: PkgId -> Handler TypedContent -getAppManifestR appId = do - -- (appsDir, appMgrDir) <- getsYesod $ (( "apps") . resourcesDir &&& staticBinDir) . appSettings - -- av <- getVersionFromQuery appsDir appExt >>= \case - -- Nothing -> sendResponseStatus status404 ("Specified App Version Not Found" :: Text) - -- Just v -> pure v - -- let appDir = (<> "/") . ( show av) . ( show appId) $ appsDir - -- addPackageHeader appMgrDir appDir appExt - -- sourceManifest appMgrDir - -- appDir - -- appExt - -- (\bsSource -> respondSource "application/json" (bsSource .| awaitForever sendChunkBS)) - -- where appExt = Extension (show appId) :: Extension "s9pk" - _ +getAppManifestR pkg = do + versionSpec <- getVersionSpecFromQuery + version <- getBestVersion pkg versionSpec + `orThrow` sendResponseStatus status404 (NotFoundE [i|#{pkg} satisfying #{versionSpec}|]) + addPackageHeader pkg version + (len, src) <- getManifest pkg version + addHeader "Content-Length" (show len) + respondSource typeJson $ src .| awaitForever sendChunkBS -getAppR :: Extension "s9pk" -> Handler TypedContent -getAppR e = do - appResourceDir <- ( "apps") . resourcesDir . appSettings <$> getYesod - getApp appResourceDir e +getAppR :: S9PK -> Handler TypedContent +getAppR file = do + let pkg = PkgId . T.pack $ takeBaseName (show file) + versionSpec <- getVersionSpecFromQuery + version <- getBestVersion pkg versionSpec + `orThrow` sendResponseStatus status404 (NotFoundE [i|#{pkg} satisfying #{versionSpec}|]) + addPackageHeader pkg version + void $ recordMetrics pkg version + (len, src) <- getPackage pkg version + addHeader "Content-Length" (show len) + respondSource typeOctet $ src .| awaitForever sendChunkBS -getApp :: KnownSymbol a => FilePath -> Extension a -> Handler TypedContent -getApp rootDir ext@(Extension appId) = do - specString <- T.filter (not . isSpace) . fromMaybe "*" <$> lookupGetParam "spec" - spec <- case readMaybe specString of - Nothing -> sendResponseStatus status400 ("Invalid App Version Specification" :: Text) - Just t -> pure t - appVersions <- liftIO $ getAvailableAppVersions rootDir ext - putStrLn $ "valid appversion for " <> (show ext :: String) <> ": " <> show appVersions - let satisfactory = filter ((<|| spec) . fst . unRegisteredAppVersion) appVersions - let best = fst . getMaxVersion <$> foldMap (Just . MaxVersion . (, fst . unRegisteredAppVersion)) satisfactory - (appsDir, appMgrDir) <- getsYesod $ (( "apps") . resourcesDir &&& staticBinDir) . appSettings - case best of - Nothing -> notFound - Just (RegisteredAppVersion (appVersion, filePath)) -> do - exists' <- liftIO $ doesFileExist filePath >>= \case - True -> pure Existent - False -> pure NonExistent - let appDir = (<> "/") . ( show appVersion) . ( toS appId) $ appsDir - let appExt = Extension (toS appId) :: Extension "s9pk" - addPackageHeader appMgrDir appDir appExt - determineEvent exists' (extension ext) filePath appVersion - where - determineEvent :: FileExistence -> String -> FilePath -> Version -> HandlerFor RegistryCtx TypedContent - -- for app files - determineEvent Existent "s9pk" fp av = do - _ <- recordMetrics appId av - chunkIt fp - -- for png, system, etc - determineEvent Existent _ fp _ = chunkIt fp - determineEvent NonExistent _ _ _ = notFound - -chunkIt :: FilePath -> HandlerFor RegistryCtx TypedContent +chunkIt :: FilePath -> Handler TypedContent chunkIt fp = do sz <- liftIO $ fileSize <$> getFileStatus fp addHeader "Content-Length" (show sz) respondSource typeOctet $ CB.sourceFile fp .| awaitForever sendChunkBS -recordMetrics :: String -> Version -> HandlerFor RegistryCtx () -recordMetrics appId appVersion = do - let appId' = T.pack appId - sa <- runDB $ fetchApp $ PkgId appId' +recordMetrics :: PkgId -> Version -> Handler () +recordMetrics pkg appVersion = do + sa <- runDB $ fetchApp $ pkg case sa of Nothing -> do - $logError $ appId' <> " not found in database" + $logError $ show pkg <> " not found in database" notFound Just a -> do let appKey' = entityKey a diff --git a/src/Handler/Icons.hs b/src/Handler/Icons.hs index 6ba81cf..6333bd7 100644 --- a/src/Handler/Icons.hs +++ b/src/Handler/Icons.hs @@ -2,6 +2,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -9,23 +10,22 @@ module Handler.Icons where import Startlude hiding ( Handler ) -import Yesod.Core - -import Data.Aeson -import qualified Data.ByteString.Lazy as BS import Data.Conduit ( (.|) , awaitForever - , runConduit ) -import qualified Data.Conduit.List as CL +import Data.String.Interpolate.IsString + ( i ) import Foundation -import Lib.External.AppMgr -import Lib.Registry +import Lib.Error ( S9Error(NotFoundE) ) +import Lib.PkgRepository ( getBestVersion + , getIcon + , getInstructions + , getLicense + ) import Lib.Types.AppIndex import Network.HTTP.Types -import Settings -import System.FilePath.Posix import Util.Shared +import Yesod.Core data IconType = PNG | JPG | JPEG | SVG deriving (Eq, Show, Generic, Read) @@ -38,66 +38,28 @@ ixt :: Text ixt = toS $ toUpper <$> drop 1 ".png" getIconsR :: PkgId -> Handler TypedContent -getIconsR appId = do - -- (appsDir, appMgrDir) <- getsYesod $ (( "apps") . resourcesDir &&& staticBinDir) . appSettings - -- spec <- getVersionFromQuery appsDir ext >>= \case - -- Nothing -> sendResponseStatus status404 ("Specified App Version Not Found" :: Text) - -- Just v -> pure v - -- let appDir = (<> "/") . ( show spec) . ( show appId) $ appsDir - -- manifest' <- sourceManifest appMgrDir appDir ext (\bsSource -> runConduit $ bsSource .| CL.foldMap BS.fromStrict) - -- manifest <- case eitherDecode manifest' of - -- Left e -> do - -- $logError "could not parse service manifest!" - -- $logError (show e) - -- sendResponseStatus status500 ("Internal Server Error" :: Text) - -- Right a -> pure a - -- mimeType <- case serviceManifestIcon manifest of - -- Nothing -> pure typePng - -- Just a -> do - -- let (_, iconExt) = splitExtension $ toS a - -- let x = toUpper <$> drop 1 iconExt - -- case readMaybe $ toS x of - -- Nothing -> do - -- $logInfo $ "unknown icon extension type: " <> show x <> ". Sending back typePlain." - -- pure typePlain - -- Just iconType -> case iconType of - -- PNG -> pure typePng - -- SVG -> pure typeSvg - -- JPG -> pure typeJpeg - -- JPEG -> pure typeJpeg - -- sourceIcon appMgrDir - -- (appDir show ext) - -- ext - -- (\bsSource -> respondSource mimeType (bsSource .| awaitForever sendChunkBS)) - -- where ext = Extension (show appId) :: Extension "s9pk" - _ +getIconsR pkg = do + spec <- getVersionSpecFromQuery + version <- getBestVersion pkg spec + `orThrow` sendResponseStatus status400 (NotFoundE [i|Icon for #{pkg} satisfying #{spec}|]) + (ct, len, src) <- getIcon pkg version + addHeader "Content-Length" (show len) + respondSource ct $ src .| awaitForever sendChunkBS getLicenseR :: PkgId -> Handler TypedContent -getLicenseR appId = do - -- (appsDir, appMgrDir) <- getsYesod $ (( "apps") . resourcesDir &&& staticBinDir) . appSettings - -- spec <- getVersionFromQuery appsDir ext >>= \case - -- Nothing -> sendResponseStatus status404 ("Specified App Version Not Found" :: Text) - -- Just v -> pure v - -- servicePath <- liftIO $ getVersionedFileFromDir appsDir ext spec - -- case servicePath of - -- Nothing -> notFound - -- Just p -> - -- sourceLicense appMgrDir p ext (\bsSource -> respondSource typePlain (bsSource .| awaitForever sendChunkBS)) - -- where ext = Extension (show appId) :: Extension "s9pk" - _ +getLicenseR pkg = do + spec <- getVersionSpecFromQuery + version <- getBestVersion pkg spec + `orThrow` sendResponseStatus status400 (NotFoundE [i|License for #{pkg} satisfying #{spec}|]) + (len, src) <- getLicense pkg version + addHeader "Content-Length" (show len) + respondSource typePlain $ src .| awaitForever sendChunkBS getInstructionsR :: PkgId -> Handler TypedContent -getInstructionsR appId = do - -- (appsDir, appMgrDir) <- getsYesod $ (( "apps") . resourcesDir &&& staticBinDir) . appSettings - -- spec <- getVersionFromQuery appsDir ext >>= \case - -- Nothing -> sendResponseStatus status404 ("Specified App Version Not Found" :: Text) - -- Just v -> pure v - -- servicePath <- liftIO $ getVersionedFileFromDir appsDir ext spec - -- case servicePath of - -- Nothing -> notFound - -- Just p -> sourceInstructions appMgrDir - -- p - -- ext - -- (\bsSource -> respondSource typePlain (bsSource .| awaitForever sendChunkBS)) - -- where ext = Extension (show appId) :: Extension "s9pk" - _ +getInstructionsR pkg = do + spec <- getVersionSpecFromQuery + version <- getBestVersion pkg spec + `orThrow` sendResponseStatus status400 (NotFoundE [i|Instructions for #{pkg} satisfying #{spec}|]) + (len, src) <- getInstructions pkg version + addHeader "Content-Length" (show len) + respondSource typePlain $ src .| awaitForever sendChunkBS diff --git a/src/Handler/Marketplace.hs b/src/Handler/Marketplace.hs index 7c04156..2fac927 100644 --- a/src/Handler/Marketplace.hs +++ b/src/Handler/Marketplace.hs @@ -12,12 +12,11 @@ module Handler.Marketplace where import Conduit ( (.|) - , MonadThrow - , mapC + , runConduit ) import Data.Aeson import qualified Data.ByteString.Lazy as BS -import qualified Data.Conduit.Text as CT +import qualified Data.Conduit.List as CL import qualified Data.HashMap.Strict as HM import Data.List import qualified Data.List.NonEmpty as NE @@ -30,21 +29,20 @@ import Database.Marketplace import qualified Database.Persist as P import Foundation import Lib.Error -import Lib.External.AppMgr -import Lib.Registry +import Lib.PkgRepository ( getManifest ) import Lib.Types.AppIndex import Lib.Types.AppIndex ( ) import Lib.Types.Category import Lib.Types.Emver import Model import Network.HTTP.Types +import Protolude.Unsafe ( unsafeFromJust ) import Settings import Startlude hiding ( Handler , from , on , sortOn ) -import System.FilePath.Posix import UnliftIO.Async import Yesod.Core import Yesod.Persist.Core @@ -242,122 +240,136 @@ getVersionLatestR = do getPackageListR :: Handler ServiceAvailableRes getPackageListR = do - getParameters <- reqGetParams <$> getRequest - let defaults = ServiceListDefaults { serviceListOrder = DESC + pkgIds <- getPkgIdsQuery + 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 + + 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 + where + defaults = ServiceListDefaults { serviceListOrder = DESC , serviceListPageLimit = 20 , serviceListPageNumber = 1 , serviceListCategory = Nothing , serviceListQuery = "" } - case lookup "ids" getParameters of - Nothing -> do - -- query for all - category <- case lookup "category" getParameters of - Nothing -> pure $ serviceListCategory defaults - Just c -> case readMaybe $ T.toUpper c of - Nothing -> do - $logInfo c - sendResponseStatus status400 ("could not read category" :: Text) - Just t -> pure $ Just t - page <- case lookup "page" getParameters of - Nothing -> pure $ serviceListPageNumber defaults - Just p -> case readMaybe p of - Nothing -> do - $logInfo p - sendResponseStatus status400 ("could not read page" :: Text) - Just t -> pure $ case t of - 0 -> 1 -- disallow page 0 so offset is not negative - _ -> t - limit' <- case lookup "per-page" getParameters of - Nothing -> pure $ serviceListPageLimit defaults - Just c -> case readMaybe $ toS c of - Nothing -> sendResponseStatus status400 ("could not read per-page" :: Text) - Just l -> pure l - query <- T.filter (not . isSpace) . 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 <- liftIO - $ mapConcurrently (getServiceDetails settings packageMetadata Nothing) filteredServices' - let (_, services) = partitionEithers serviceDetailResult - pure $ ServiceAvailableRes services + getPkgIdsQuery :: Handler (Maybe [PackageVersion]) + getPkgIdsQuery = lookupGetParam "ids" >>= \case + Nothing -> pure Nothing + Just ids -> case eitherDecodeStrict (encodeUtf8 ids) of + Left _ -> do + let e = InvalidParamsE "get:ids" ids + $logWarn (show e) + sendResponseStatus status400 e + Right a -> pure a + getCategoryQuery :: Handler (Maybe CategoryTitle) + getCategoryQuery = lookupGetParam "category" >>= \case + Nothing -> pure Nothing + Just c -> case readMaybe . T.toUpper $ c of + Nothing -> do + let e = InvalidParamsE "get:category" c + $logWarn (show e) + sendResponseStatus status400 e + Just t -> pure $ Just t + getPageQuery :: Handler Int64 + getPageQuery = lookupGetParam "page" >>= \case + Nothing -> pure $ serviceListPageNumber defaults + Just p -> case readMaybe p of + Nothing -> do + let e = InvalidParamsE "get:page" p + $logWarn (show e) + sendResponseStatus status400 e + Just t -> pure $ case t of + 0 -> 1 -- disallow page 0 so offset is not negative + _ -> t + getLimitQuery :: Handler Int64 + getLimitQuery = lookupGetParam "per-page" >>= \case + Nothing -> pure $ serviceListPageLimit defaults + Just pp -> case readMaybe pp of + Nothing -> do + let e = InvalidParamsE "get:per-page" pp + $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 $ "best version could not be found for " <> show appId <> " with spec " <> show spec + Just v -> do + pure $ Right (Just v, appId) - Just packageVersionList -> case eitherDecode $ BS.fromStrict $ encodeUtf8 packageVersionList of - Left e -> sendResponseStatus status400 ("could not parse query param \"ids\"" <> show e :: Text) - Right (packages :: [PackageVersion]) -> 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 <- liftIO - $ mapConcurrently (uncurry $ getServiceDetails settings packageMetadata) availableServices - -- @TODO fix _ error - let (_, services) = partitionEithers serviceDetailResult - pure $ ServiceAvailableRes services - where - 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 - $ "best version could not be found for " - <> show appId - <> " with spec " - <> show spec - Just v -> do - pure $ Right (Just v, appId) - -getServiceDetails :: (MonadUnliftIO m, Monad m, MonadError IOException m) +getServiceDetails :: (MonadUnliftIO m, Monad m, MonadResource m) => AppSettings -> (HM.HashMap PkgId ([Version], [CategoryTitle])) -> Maybe Version -> PkgId -> m (Either Text ServiceRes) -getServiceDetails settings metadata maybeVersion appId = do - -- packageMetadata <- case HM.lookup appId metadata of - -- Nothing -> throwIO $ NotFoundE [i|#{appId} not found.|] - -- Just m -> pure m +getServiceDetails settings metadata maybeVersion pkg = do + packageMetadata <- case HM.lookup pkg metadata of + Nothing -> throwIO $ NotFoundE [i|#{pkg} not found.|] + Just m -> pure m -- let (appsDir, appMgrDir) = (( "apps") . resourcesDir &&& staticBinDir) settings - -- let domain = registryHostname settings - -- version <- case maybeVersion of - -- Nothing -> do - -- -- grab first value, which will be the latest version - -- case fst packageMetadata of - -- [] -> throwIO $ NotFoundE $ "no latest version found for " <> show appId - -- x : _ -> pure x - -- Just v -> pure v + let domain = registryHostname settings + version <- case maybeVersion of + Nothing -> do + -- grab first value, which will be the latest version + case fst packageMetadata of + [] -> throwIO $ NotFoundE $ "no latest version found for " <> show pkg + x : _ -> pure x + Just v -> pure v -- let appDir = (<> "/") . ( show version) . ( show appId) $ appsDir -- let appExt = Extension (show appId) :: Extension "s9pk" - -- manifest' <- sourceManifest appMgrDir appDir appExt (\bs -> sinkMem (bs .| mapC BS.fromStrict)) - -- case eitherDecode $ manifest' of - -- Left e -> pure $ Left $ "Could not parse service manifest for " <> show appId <> ": " <> show e - -- Right m -> do - -- d <- liftIO $ mapConcurrently (mapDependencyMetadata domain metadata) - -- (HM.toList $ serviceManifestDependencies m) - -- pure $ Right $ ServiceRes { serviceResIcon = [i|https://#{domain}/package/icon/#{appId}|] - -- , serviceResManifest = decode $ manifest' -- pass through raw JSON Value - -- , serviceResCategories = snd packageMetadata - -- , serviceResInstructions = [i|https://#{domain}/package/instructions/#{appId}|] - -- , serviceResLicense = [i|https://#{domain}/package/license/#{appId}|] - -- , serviceResVersions = fst packageMetadata - -- , serviceResDependencyInfo = HM.fromList $ snd $ partitionEithers d - -- } - _ + manifest <- flip runReaderT settings $ (snd <$> getManifest pkg version) >>= \bs -> + runConduit $ bs .| CL.foldMap BS.fromStrict + case eitherDecode manifest of + Left e -> pure $ Left $ "Could not parse service manifest for " <> show pkg <> ": " <> show e + Right m -> do + d <- liftIO $ mapConcurrently (mapDependencyMetadata domain metadata) + (HM.toList $ serviceManifestDependencies m) + pure $ Right $ ServiceRes { serviceResIcon = [i|https://#{domain}/package/icon/#{pkg}|] + -- pass through raw JSON Value, we have checked its correct parsing above + , serviceResManifest = unsafeFromJust . decode $ manifest + , serviceResCategories = snd packageMetadata + , serviceResInstructions = [i|https://#{domain}/package/instructions/#{pkg}|] + , serviceResLicense = [i|https://#{domain}/package/license/#{pkg}|] + , serviceResVersions = fst packageMetadata + , serviceResDependencyInfo = HM.fromList $ snd $ partitionEithers d + } mapDependencyMetadata :: (MonadIO m) => Text diff --git a/src/Handler/Types/Status.hs b/src/Handler/Types/Status.hs index 51b56f7..5c23e79 100644 --- a/src/Handler/Types/Status.hs +++ b/src/Handler/Types/Status.hs @@ -8,31 +8,20 @@ import Startlude hiding ( toLower ) import Data.Aeson import Yesod.Core.Content +import Data.Text import Lib.Types.Emver import Orphans.Emver ( ) -import Data.Text data AppVersionRes = AppVersionRes - { appVersionVersion :: Version - , appVersionMinCompanion :: Maybe Version - , appVersionReleaseNotes :: Maybe Text + { appVersionVersion :: Version } deriving (Eq, Show) instance ToJSON AppVersionRes where - toJSON AppVersionRes { appVersionVersion, appVersionMinCompanion, appVersionReleaseNotes } = - let rn = case appVersionReleaseNotes of - Nothing -> [] - Just x -> ["release-notes" .= x] - mc = case appVersionMinCompanion of - Nothing -> [] - Just x -> ["minCompanion" .= x] - in object $ ["version" .= appVersionVersion] <> mc <> rn + toJSON AppVersionRes { appVersionVersion } = object $ ["version" .= appVersionVersion] instance ToContent AppVersionRes where toContent = toContent . toJSON instance ToTypedContent AppVersionRes where toTypedContent = toTypedContent . toJSON - --- Ugh instance ToContent (Maybe AppVersionRes) where toContent = toContent . toJSON instance ToTypedContent (Maybe AppVersionRes) where @@ -47,9 +36,10 @@ instance ToJSON SystemStatus where toJSON = String . toLower . show data OSVersionRes = OSVersionRes - { osVersionStatus :: SystemStatus + { osVersionStatus :: SystemStatus , osVersionVersion :: Version - } deriving (Eq, Show) + } + deriving (Eq, Show) instance ToJSON OSVersionRes where toJSON OSVersionRes {..} = object ["status" .= osVersionStatus, "version" .= osVersionVersion] instance ToContent OSVersionRes where diff --git a/src/Handler/Version.hs b/src/Handler/Version.hs index 74cd75f..100aa53 100644 --- a/src/Handler/Version.hs +++ b/src/Handler/Version.hs @@ -2,52 +2,51 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} module Handler.Version where import Startlude hiding ( Handler ) -import Control.Monad.Trans.Maybe import Yesod.Core +import qualified Data.Attoparsec.Text as Atto +import Data.String.Interpolate.IsString + ( i ) +import qualified Data.Text as T import Foundation import Handler.Types.Status -import Lib.Registry -import Lib.Types.Emver +import Lib.Error ( S9Error(NotFoundE) ) +import Lib.PkgRepository ( getBestVersion ) +import Lib.Types.AppIndex ( PkgId ) +import Lib.Types.Emver ( parseVersion + , satisfies + ) +import Network.HTTP.Types.Status ( status404 ) import Settings import System.FilePath ( () ) -import Util.Shared -import System.Directory ( doesFileExist ) +import UnliftIO.Directory ( listDirectory ) +import Util.Shared ( getVersionSpecFromQuery + , orThrow + ) getVersionR :: Handler AppVersionRes -getVersionR = do - rv <- AppVersionRes . registryVersion . appSettings <$> getYesod - pure $ rv Nothing Nothing +getVersionR = AppVersionRes . registryVersion . appSettings <$> getYesod -getVersionAppR :: Text -> Handler (Maybe AppVersionRes) -getVersionAppR appId = do - (appsDir, appMgrDir) <- getsYesod $ (( "apps") . resourcesDir &&& staticBinDir) . appSettings - res <- getVersionWSpec appsDir appExt - case res of - Nothing -> pure res - Just r -> do - let appDir = (<> "/") . ( (show $ appVersionVersion r)) . ( toS appId) $ appsDir - addPackageHeader appMgrDir appDir appExt - pure res - where appExt = Extension (toS appId) :: Extension "s9pk" +getPkgVersionR :: PkgId -> Handler AppVersionRes +getPkgVersionR pkg = do + spec <- getVersionSpecFromQuery + AppVersionRes <$> getBestVersion pkg spec `orThrow` sendResponseStatus + status404 + (NotFoundE [i|Version for #{pkg} satisfying #{spec}|]) --- @TODO - deprecate -getVersionSysR :: Text -> Handler (Maybe AppVersionRes) -getVersionSysR sysAppId = runMaybeT $ do - sysDir <- ( "sys") . resourcesDir . appSettings <$> getYesod - avr <- MaybeT $ getVersionWSpec sysDir sysExt - let notesPath = sysDir "agent" show (appVersionVersion avr) "release-notes.md" - notes <- liftIO $ ifM (doesFileExist notesPath) (Just <$> readFile notesPath) (pure Nothing) - pure $ avr { appVersionMinCompanion = Just $ Version (1, 1, 0, 0), appVersionReleaseNotes = notes } - where sysExt = Extension (toS sysAppId) :: Extension "" - -getVersionWSpec :: KnownSymbol a => FilePath -> Extension a -> Handler (Maybe AppVersionRes) -getVersionWSpec rootDir ext = do - av <- getVersionFromQuery rootDir ext - pure $ liftA3 AppVersionRes av (pure Nothing) (pure Nothing) +getEosVersionR :: Handler AppVersionRes +getEosVersionR = do + spec <- getVersionSpecFromQuery + root <- getsYesod $ ( "eos") . resourcesDir . appSettings + subdirs <- listDirectory root + let (failures, successes) = partitionEithers $ (Atto.parseOnly parseVersion . T.pack) <$> subdirs + for_ failures $ \f -> $logWarn [i|Emver Parse Failure for EOS: #{f}|] + let res = headMay . sortOn Down . filter (`satisfies` spec) $ successes + maybe (sendResponseStatus status404 (NotFoundE [i|EOS version satisfying #{spec}|])) (pure . AppVersionRes) res diff --git a/src/Lib/Error.hs b/src/Lib/Error.hs index f743558..4e73dbc 100644 --- a/src/Lib/Error.hs +++ b/src/Lib/Error.hs @@ -15,6 +15,7 @@ data S9Error = PersistentE Text | AppMgrE Text ExitCode | NotFoundE Text + | InvalidParamsE Text Text deriving (Show, Eq) instance Exception S9Error @@ -22,14 +23,16 @@ instance Exception S9Error -- | Redact any sensitive data in this function toError :: S9Error -> Error toError = \case - PersistentE t -> Error DATABASE_ERROR t - AppMgrE cmd code -> Error APPMGR_ERROR [i|"appmgr #{cmd}" exited with #{code}|] - NotFoundE e -> Error NOT_FOUND [i|#{e}|] + PersistentE t -> Error DATABASE_ERROR t + AppMgrE cmd code -> Error APPMGR_ERROR [i|"appmgr #{cmd}" exited with #{code}|] + NotFoundE e -> Error NOT_FOUND [i|#{e}|] + InvalidParamsE e m -> Error INVALID_PARAMS [i|Could not parse request parameters #{e}: #{m}|] data ErrorCode = DATABASE_ERROR | APPMGR_ERROR | NOT_FOUND + | INVALID_PARAMS deriving (Eq, Show) instance ToJSON ErrorCode where @@ -54,9 +57,10 @@ instance ToContent S9Error where toStatus :: S9Error -> Status toStatus = \case - PersistentE _ -> status500 - AppMgrE _ _ -> status500 - NotFoundE _ -> status404 + PersistentE _ -> status500 + AppMgrE _ _ -> status500 + NotFoundE _ -> status404 + InvalidParamsE _ _ -> status400 handleS9ErrT :: MonadHandler m => S9ErrT m a -> m a diff --git a/src/Lib/External/AppMgr.hs b/src/Lib/External/AppMgr.hs index 70a6ab0..a49fb90 100644 --- a/src/Lib/External/AppMgr.hs +++ b/src/Lib/External/AppMgr.hs @@ -23,7 +23,6 @@ import Conduit ( (.|) import qualified Data.Conduit.List as CL import Data.Conduit.Process.Typed import Lib.Error -import Lib.Registry import System.FilePath ( () ) import UnliftIO ( MonadUnliftIO , catch diff --git a/src/Lib/PkgRepository.hs b/src/Lib/PkgRepository.hs index 1c83329..b062d93 100644 --- a/src/Lib/PkgRepository.hs +++ b/src/Lib/PkgRepository.hs @@ -28,6 +28,9 @@ import Control.Monad.Reader.Has ( Has ) import Data.Aeson ( eitherDecodeFileStrict' ) import qualified Data.Attoparsec.Text as Atto +import Data.ByteString ( readFile + , writeFile + ) import Data.String.Interpolate.IsString ( i ) import qualified Data.Text as T @@ -37,7 +40,9 @@ import Lib.Types.AppIndex ( PkgId(..) , ServiceManifest(serviceManifestIcon) ) import Lib.Types.Emver ( Version + , VersionRange , parseVersion + , satisfies ) import Startlude ( ($) , (&&) @@ -46,11 +51,13 @@ import Startlude ( ($) , (<>) , Bool(..) , ByteString + , Down(Down) , Either(Left, Right) , Eq((==)) , Exception , FilePath , IO + , Integer , Maybe(Just, Nothing) , MonadIO(liftIO) , MonadReader @@ -59,10 +66,12 @@ import Startlude ( ($) , find , for_ , fromMaybe + , headMay , not , partitionEithers , pure , show + , sortOn , throwIO ) import System.FSNotify ( Event(Added) @@ -87,7 +96,8 @@ import UnliftIO ( MonadUnliftIO ) import UnliftIO ( tryPutMVar ) import UnliftIO.Concurrent ( forkIO ) -import UnliftIO.Directory ( listDirectory +import UnliftIO.Directory ( getFileSize + , listDirectory , removeFile , renameFile ) @@ -116,6 +126,15 @@ getVersionsFor pkg = do for_ failures $ \f -> $logWarn [i|Emver Parse Failure for #{pkg}: #{f}|] pure successes +getViableVersions :: (MonadIO m, MonadReader r m, Has PkgRepo r, MonadLogger m) => PkgId -> VersionRange -> m [Version] +getViableVersions pkg spec = filter (`satisfies` spec) <$> getVersionsFor pkg + +getBestVersion :: (MonadIO m, MonadReader r m, Has PkgRepo r, MonadLogger m) + => PkgId + -> VersionRange + -> m (Maybe Version) +getBestVersion pkg spec = headMay . sortOn Down <$> getViableVersions pkg spec + -- extract all package assets into their own respective files extractPkg :: (MonadUnliftIO m, MonadReader r m, Has PkgRepo r, MonadLoggerIO m) => FilePath -> m () extractPkg fp = (`onException` cleanup) $ do @@ -125,6 +144,7 @@ extractPkg fp = (`onException` cleanup) $ do -- let s9pk = pkgRoot show pkg <.> "s9pk" manifestTask <- async $ liftIO . runResourceT $ AppMgr.sourceManifest appmgr fp $ sinkIt (pkgRoot "manifest.json") + pkgHashTask <- async $ AppMgr.getPackageHash appmgr fp instructionsTask <- async $ liftIO . runResourceT $ AppMgr.sourceInstructions appmgr fp $ sinkIt (pkgRoot "instructions.md") licenseTask <- async $ liftIO . runResourceT $ AppMgr.sourceLicense appmgr fp $ sinkIt (pkgRoot "license.md") @@ -139,6 +159,8 @@ extractPkg fp = (`onException` cleanup) $ do wait iconTask let iconDest = "icon" <.> T.unpack (fromMaybe "png" (serviceManifestIcon manifest)) liftIO $ renameFile (pkgRoot "icon.tmp") (pkgRoot iconDest) + hash <- wait pkgHashTask + liftIO $ writeFile (pkgRoot "hash.bin") hash wait instructionsTask wait licenseTask where @@ -167,28 +189,40 @@ watchPkgRepoRoot = do Added path _ isDir -> not isDir && takeExtension path == ".s9pk" _ -> False -getManifest :: (MonadResource m, MonadReader r m, Has PkgRepo r) => PkgId -> Version -> ConduitT () ByteString m () +getManifest :: (MonadResource m, MonadReader r m, Has PkgRepo r) + => PkgId + -> Version + -> m (Integer, ConduitT () ByteString m ()) getManifest pkg version = do root <- asks pkgRepoFileRoot let manifestPath = root show pkg show version "manifest.json" - sourceFile manifestPath + n <- getFileSize manifestPath + pure $ (n, sourceFile manifestPath) -getInstructions :: (MonadResource m, MonadReader r m, Has PkgRepo r) => PkgId -> Version -> ConduitT () ByteString m () +getInstructions :: (MonadResource m, MonadReader r m, Has PkgRepo r) + => PkgId + -> Version + -> m (Integer, ConduitT () ByteString m ()) getInstructions pkg version = do root <- asks pkgRepoFileRoot let instructionsPath = root show pkg show version "instructions.md" - sourceFile instructionsPath + n <- getFileSize instructionsPath + pure $ (n, sourceFile instructionsPath) -getLicense :: (MonadResource m, MonadReader r m, Has PkgRepo r) => PkgId -> Version -> ConduitT () ByteString m () +getLicense :: (MonadResource m, MonadReader r m, Has PkgRepo r) + => PkgId + -> Version + -> m (Integer, ConduitT () ByteString m ()) getLicense pkg version = do root <- asks pkgRepoFileRoot let licensePath = root show pkg show version "license.md" - sourceFile licensePath + n <- getFileSize licensePath + pure $ (n, sourceFile licensePath) getIcon :: (MonadResource m, MonadReader r m, Has PkgRepo r) => PkgId -> Version - -> m (ContentType, ConduitT () ByteString m ()) + -> m (ContentType, Integer, ConduitT () ByteString m ()) getIcon pkg version = do root <- asks pkgRepoFileRoot let pkgRoot = root show pkg show version @@ -203,4 +237,21 @@ getIcon pkg version = do ".svg" -> typeSvg ".gif" -> typeGif _ -> typePlain - pure $ (ct, sourceFile (pkgRoot x)) + n <- getFileSize (pkgRoot x) + pure $ (ct, n, sourceFile (pkgRoot x)) + +getHash :: (MonadIO m, MonadReader r m, Has PkgRepo r) => PkgId -> Version -> m ByteString +getHash pkg version = do + root <- asks pkgRepoFileRoot + let hashPath = root show pkg show version "hash.bin" + liftIO $ readFile hashPath + +getPackage :: (MonadResource m, MonadReader r m, Has PkgRepo r) + => PkgId + -> Version + -> m (Integer, ConduitT () ByteString m ()) +getPackage pkg version = do + root <- asks pkgRepoFileRoot + let pkgPath = root show pkg show version show pkg <.> "s9pk" + n <- getFileSize pkgPath + pure (n, sourceFile pkgPath) diff --git a/src/Lib/Types/Emver.hs b/src/Lib/Types/Emver.hs index 0c9a356..014595a 100644 --- a/src/Lib/Types/Emver.hs +++ b/src/Lib/Types/Emver.hs @@ -34,21 +34,20 @@ module Lib.Types.Emver , exactly , parseVersion , parseRange - ) -where + ) where -import Prelude +import Control.Applicative ( Alternative((<|>)) + , liftA2 + ) +import Data.Aeson import qualified Data.Attoparsec.Text as Atto import Data.Function -import Data.Functor ( (<&>) - , ($>) - ) -import Control.Applicative ( liftA2 - , Alternative((<|>)) +import Data.Functor ( ($>) + , (<&>) ) import Data.String ( IsString(..) ) import qualified Data.Text as T -import Data.Aeson +import Prelude import Startlude ( Hashable ) -- | AppVersion is the core representation of the SemverQuad type. diff --git a/src/Util/Function.hs b/src/Util/Function.hs index cb5c771..fb20345 100644 --- a/src/Util/Function.hs +++ b/src/Util/Function.hs @@ -21,3 +21,6 @@ mapFind finder mapping (b : bs) = (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 4eb3c41..58b370e 100644 --- a/src/Util/Shared.hs +++ b/src/Util/Shared.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} module Util.Shared where @@ -8,33 +9,27 @@ import qualified Data.Text as T import Network.HTTP.Types import Yesod.Core -import Data.Semigroup +import Control.Monad.Reader.Has ( Has ) import Foundation -import Lib.External.AppMgr -import Lib.Registry +import Lib.PkgRepository ( PkgRepo + , getHash + ) +import Lib.Types.AppIndex ( PkgId ) import Lib.Types.Emver -getVersionFromQuery :: KnownSymbol a => FilePath -> Extension a -> Handler (Maybe Version) -getVersionFromQuery rootDir ext = do +getVersionSpecFromQuery :: Handler VersionRange +getVersionSpecFromQuery = do specString <- T.filter (not . isSpace) . fromMaybe "*" <$> lookupGetParam "spec" - spec <- case readMaybe specString of + case readMaybe specString of Nothing -> sendResponseStatus status400 ("Invalid App Version Specification" :: Text) Just t -> pure t - getBestVersion rootDir ext spec -getBestVersion :: (MonadIO m, KnownSymbol a, MonadLogger m) - => FilePath - -> Extension a - -> VersionRange - -> m (Maybe Version) -getBestVersion rootDir ext spec = do - -- @TODO change to db query? - appVersions <- liftIO $ getAvailableAppVersions rootDir ext - let satisfactory = filter ((<|| spec) . fst . unRegisteredAppVersion) appVersions - let best = getMax <$> foldMap (Just . Max . fst . unRegisteredAppVersion) satisfactory - pure best - -addPackageHeader :: (MonadUnliftIO m, MonadHandler m) => FilePath -> FilePath -> S9PK -> m () -addPackageHeader appMgrDir appDir appExt = do - packageHash <- getPackageHash appMgrDir appDir appExt +addPackageHeader :: (MonadUnliftIO m, MonadHandler m, MonadReader r m, Has PkgRepo r) => PkgId -> Version -> m () +addPackageHeader pkg version = do + packageHash <- getHash pkg version addHeader "X-S9PK-HASH" $ decodeUtf8 packageHash + +orThrow :: MonadHandler m => m (Maybe a) -> m a -> m a +orThrow action other = action >>= \case + Nothing -> other + Just x -> pure x From 427c31c88630fd7179432db02c9864490767261c Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Tue, 28 Sep 2021 17:59:28 -0600 Subject: [PATCH 32/48] improves logging --- package.yaml | 2 + resources/sys/appmgr/0.0.0/appmgr | 1 - resources/sys/proxy.pac/0.1.0/proxy.pac | 0 resources/sys/sys.tar.gz/1.1.1/sys.tar.gz | 1 - src/Application.hs | 5 +- src/Foundation.hs | 60 ++++++++++++++++++++++- src/Lib/PkgRepository.hs | 1 + stack.yaml | 6 +-- 8 files changed, 67 insertions(+), 9 deletions(-) delete mode 100644 resources/sys/appmgr/0.0.0/appmgr delete mode 100644 resources/sys/proxy.pac/0.1.0/proxy.pac delete mode 100644 resources/sys/sys.tar.gz/1.1.1/sys.tar.gz diff --git a/package.yaml b/package.yaml index 111f690..422dfe3 100644 --- a/package.yaml +++ b/package.yaml @@ -15,6 +15,7 @@ default-extensions: dependencies: - base >=4.12 && <5 - aeson + - ansi-terminal - attoparsec - binary - bytestring @@ -36,6 +37,7 @@ dependencies: - interpolate - lens - monad-logger + - monad-logger-extras - persistent - persistent-postgresql - persistent-template diff --git a/resources/sys/appmgr/0.0.0/appmgr b/resources/sys/appmgr/0.0.0/appmgr deleted file mode 100644 index bfad61c..0000000 --- a/resources/sys/appmgr/0.0.0/appmgr +++ /dev/null @@ -1 +0,0 @@ -appmgr downloaded \ No newline at end of file diff --git a/resources/sys/proxy.pac/0.1.0/proxy.pac b/resources/sys/proxy.pac/0.1.0/proxy.pac deleted file mode 100644 index e69de29..0000000 diff --git a/resources/sys/sys.tar.gz/1.1.1/sys.tar.gz b/resources/sys/sys.tar.gz/1.1.1/sys.tar.gz deleted file mode 100644 index 32e0202..0000000 --- a/resources/sys/sys.tar.gz/1.1.1/sys.tar.gz +++ /dev/null @@ -1 +0,0 @@ -get it all up down around \ No newline at end of file diff --git a/src/Application.hs b/src/Application.hs index 993fb37..cb1d049 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -291,9 +291,9 @@ startWeb foundation = do where startWeb' app = (`onException` (appStopFsNotify foundation)) $ do let AppSettings {..} = appSettings foundation - putStrLn @Text $ "Launching Tor Web Server on port " <> show torPort + runLog $ $logInfo $ "Launching Tor Web Server on port " <> show torPort torAction <- async $ runSettings (warpSettings torPort foundation) app - putStrLn @Text $ "Launching Web Server on port " <> show appPort + runLog $ $logInfo $ "Launching Web Server on port " <> show appPort action <- if sslAuto then async $ runTLS (tlsSettings sslCertLocation sslKeyLocation) (warpSettings appPort foundation) app else async $ runSettings (warpSettings appPort foundation) app @@ -316,6 +316,7 @@ startWeb foundation = do putMVar (appShouldRestartWeb foundation) False putStrLn @Text "Restarting Web Server" startWeb' app + runLog a = runLoggingT a (messageLoggerSource foundation (appLogger foundation)) restartWeb :: RegistryCtx -> IO () restartWeb foundation = do diff --git a/src/Foundation.hs b/src/Foundation.hs index 33e586e..44c228c 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -2,27 +2,47 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeApplications #-} module Foundation where import Startlude hiding ( Handler ) -import Control.Monad.Logger ( LogSource ) +import Control.Monad.Logger ( Loc + , LogSource + , LogStr + , ToLogStr(toLogStr) + , fromLogStr + ) import Database.Persist.Sql hiding ( update ) import Lib.Registry import Yesod.Core import Yesod.Core.Types ( HandlerData(handlerEnv) - , Logger + , Logger(loggerDate) , RunHandlerEnv(rheChild, rheSite) + , loggerPutStr ) import qualified Yesod.Core.Unsafe as Unsafe +import qualified Control.Monad.Logger.Extras as Extra +import Control.Monad.Logger.Extras ( wrapSGRCode ) import Control.Monad.Reader.Has ( Has(extract, update) ) +import Data.String.Interpolate.IsString + ( i ) +import qualified Data.Text as T +import Language.Haskell.TH ( Loc(..) ) import Lib.PkgRepository import Lib.Types.AppIndex import Settings +import System.Console.ANSI.Codes ( Color(..) + , ColorIntensity(..) + , ConsoleLayer(Foreground) + , SGR(SetColor) + ) import System.FilePath ( () ) +import Yesod ( defaultMessageLoggerSource ) import Yesod.Persist.Core -- | The foundation datatype for your application. This can be a good place to @@ -101,6 +121,42 @@ instance Yesod RegistryCtx where makeLogger :: RegistryCtx -> IO Logger makeLogger = return . appLogger + messageLoggerSource :: RegistryCtx -> Logger -> Loc -> LogSource -> LogLevel -> LogStr -> IO () + messageLoggerSource ctx logger = \loc src lvl str -> do + shouldLog <- shouldLogIO ctx src lvl + when shouldLog $ do + date <- loggerDate logger + let + formatted = + toLogStr date + <> ( toLogStr + . wrapSGRCode [SetColor Foreground Vivid (colorFor lvl)] + $ fromLogStr + ( " [" + <> renderLvl lvl + <> (if T.null src then mempty else "#" <> toLogStr src) + <> "] " + <> str + ) + ) + <> (toLogStr + (wrapSGRCode [SetColor Foreground Dull White] + [i| @ #{loc_filename loc}:#{fst $ loc_start loc}\n|] + ) + ) + loggerPutStr logger formatted + where + renderLvl lvl = case lvl of + LevelOther t -> toLogStr t + _ -> toLogStr @String $ drop 5 $ show lvl + colorFor = \case + LevelDebug -> Green + LevelInfo -> Blue + LevelWarn -> Yellow + LevelError -> Red + LevelOther _ -> White + + -- How to run database actions. instance YesodPersist RegistryCtx where type YesodPersistBackend RegistryCtx = SqlBackend diff --git a/src/Lib/PkgRepository.hs b/src/Lib/PkgRepository.hs index b062d93..9c4a4e7 100644 --- a/src/Lib/PkgRepository.hs +++ b/src/Lib/PkgRepository.hs @@ -173,6 +173,7 @@ extractPkg fp = (`onException` cleanup) $ do watchPkgRepoRoot :: (MonadUnliftIO m, MonadReader r m, Has PkgRepo r, MonadLoggerIO m) => m (IO Bool) watchPkgRepoRoot = do + $logInfo "Starting FSNotify Watch Manager" root <- asks pkgRepoFileRoot runInIO <- askRunInIO box <- newEmptyMVar @_ @() diff --git a/stack.yaml b/stack.yaml index 167ce3e..9739af5 100644 --- a/stack.yaml +++ b/stack.yaml @@ -29,7 +29,7 @@ resolver: lts-18.11 # - auto-update # - wai packages: -- . + - . # Dependency packages to be pulled from upstream that are not in the resolver. # These entries can reference officially published versions as well as # forks / in-progress versions pinned to a git hash. For example: @@ -42,8 +42,8 @@ packages: extra-deps: - protolude-0.3.0 - esqueleto-3.5.1.0 + - monad-logger-extras-0.1.1.1 - wai-request-spec-0.10.2.4 - # Override default flag values for local packages and extra-deps # flags: {} @@ -68,4 +68,4 @@ extra-deps: # Allow a newer minor version of GHC than the snapshot specifies # compiler-check: newer-minor # docker: - # enable: true +# enable: true From 37c9a2bf6f55c0d1ec8a38de4625e25430f732ca Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Tue, 28 Sep 2021 20:19:32 -0600 Subject: [PATCH 33/48] fixes extraction logic, found a bug in System.Process --- src/Lib/External/AppMgr.hs | 69 +++++++++++++++++++++++++++++++------- src/Lib/PkgRepository.hs | 16 ++++++--- 2 files changed, 67 insertions(+), 18 deletions(-) diff --git a/src/Lib/External/AppMgr.hs b/src/Lib/External/AppMgr.hs index a49fb90..86dad17 100644 --- a/src/Lib/External/AppMgr.hs +++ b/src/Lib/External/AppMgr.hs @@ -10,7 +10,11 @@ module Lib.External.AppMgr where -import Startlude hiding ( catch ) +import Startlude hiding ( bracket + , catch + , finally + , handle + ) import qualified Data.ByteString.Lazy as LBS import Data.String.Interpolate.IsString @@ -22,11 +26,25 @@ import Conduit ( (.|) ) import qualified Data.Conduit.List as CL import Data.Conduit.Process.Typed +import GHC.IO.Exception ( IOErrorType(NoSuchThing) + , IOException + ( IOError + , ioe_description + , ioe_errno + , ioe_filename + , ioe_handle + , ioe_location + , ioe_type + ) + ) import Lib.Error import System.FilePath ( () ) import UnliftIO ( MonadUnliftIO , catch ) +import UnliftIO ( bracket ) +import UnliftIO ( finally ) +import UnliftIO.Exception ( handle ) readProcessWithExitCode' :: MonadIO m => String -> [String] -> ByteString -> m (ExitCode, ByteString, ByteString) readProcessWithExitCode' a b c = liftIO $ do @@ -41,45 +59,70 @@ readProcessWithExitCode' a b c = liftIO $ do (LBS.toStrict <$> getStdout process) (LBS.toStrict <$> getStderr process) -readProcessInheritStderr :: MonadUnliftIO m +readProcessInheritStderr :: forall m a + . MonadUnliftIO m => String -> [String] -> ByteString -> (ConduitT () ByteString m () -> m a) -- this is because we can't clean up the process in the unCPS'ed version of this -> m a -readProcessInheritStderr a b c sink = do +readProcessInheritStderr a b c sink = handle help $ do let pc = setStdin (byteStringInput $ LBS.fromStrict c) $ setEnvInherit + $ setStderr (useHandleOpen stderr) $ setStdout createSource $ System.Process.Typed.proc a b - withProcessTerm_ pc $ \p -> sink (getStdout p) + withProcessTerm' pc $ \p -> sink (getStdout p) + where + withProcessTerm' :: (MonadUnliftIO m) + => ProcessConfig stdin stdout stderr + -> (Process stdin stdout stderr -> m a) + -> m a + withProcessTerm' cfg = bracket (startProcess cfg) $ \p -> do + stopProcess p + `catch` (\e -> if ioe_type e == NoSuchThing && ioe_description e == "No child processes" + then pure () + else throwIO e + ) + help e@IOError {..} = do + print $ ioe_handle + print $ ioe_type + print $ ioe_location + print $ ioe_description + print $ ioe_errno + print $ ioe_filename + throwIO e sourceManifest :: (MonadUnliftIO m) => FilePath -> FilePath -> (ConduitT () ByteString m () -> m r) -> m r sourceManifest appmgrPath pkgFile sink = do let appmgr = readProcessInheritStderr (appmgrPath "embassy-sdk") ["inspect", "manifest", pkgFile] "" - appmgr sink `catch` \ece -> throwIO (AppMgrE [i|embassy-sdk inspect manifest #{pkgFile}|] (eceExitCode ece)) + appmgr sink `catch` \ece -> + print ece *> throwIO (AppMgrE [i|embassy-sdk inspect manifest #{pkgFile}|] (eceExitCode ece)) sourceIcon :: (MonadUnliftIO m) => FilePath -> FilePath -> (ConduitT () ByteString m () -> m r) -> m r sourceIcon appmgrPath pkgFile sink = do - let appmgr = readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "icon", pkgFile] "" - appmgr sink `catch` \ece -> throwIO $ AppMgrE [i|embassy-sdk inspect icon #{pkgFile}|] (eceExitCode ece) + let appmgr = readProcessInheritStderr (appmgrPath "embassy-sdk") ["inspect", "icon", pkgFile] "" + appmgr sink + `catch` \ece -> print ece *> throwIO (AppMgrE [i|embassy-sdk inspect icon #{pkgFile}|] (eceExitCode ece)) getPackageHash :: (MonadUnliftIO m) => FilePath -> FilePath -> m ByteString getPackageHash appmgrPath pkgFile = do - let appmgr = readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "hash", pkgFile] "" + let appmgr = readProcessInheritStderr (appmgrPath "embassy-sdk") ["inspect", "hash", pkgFile] "" appmgr (\bsSource -> runConduit $ bsSource .| CL.foldMap id) - `catch` \ece -> throwIO $ AppMgrE [i|embassy-sdk inspect hash #{pkgFile}|] (eceExitCode ece) + `catch` \ece -> print ece *> throwIO (AppMgrE [i|embassy-sdk inspect hash #{pkgFile}|] (eceExitCode ece)) sourceInstructions :: (MonadUnliftIO m) => FilePath -> FilePath -> (ConduitT () ByteString m () -> m r) -> m r sourceInstructions appmgrPath pkgFile sink = do - let appmgr = readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "instructions", pkgFile] "" - appmgr sink `catch` \ece -> throwIO $ AppMgrE [i|embassy-sdk inspect instructions #{pkgFile}|] (eceExitCode ece) + let appmgr = readProcessInheritStderr (appmgrPath "embassy-sdk") ["inspect", "instructions", pkgFile] "" + appmgr sink `catch` \ece -> + print ece *> throwIO (AppMgrE [i|embassy-sdk inspect instructions #{pkgFile}|] (eceExitCode ece)) sourceLicense :: (MonadUnliftIO m) => FilePath -> FilePath -> (ConduitT () ByteString m () -> m r) -> m r sourceLicense appmgrPath pkgFile sink = do - let appmgr = readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "license", pkgFile] "" - appmgr sink `catch` \ece -> throwIO $ AppMgrE [i|embassy-sdk inspect license #{pkgFile}|] (eceExitCode ece) + let appmgr = readProcessInheritStderr (appmgrPath "embassy-sdk") ["inspect", "license", pkgFile] "" + appmgr sink + `catch` \ece -> print ece *> throwIO (AppMgrE [i|embassy-sdk inspect license #{pkgFile}|] (eceExitCode ece)) sinkMem :: (Monad m, Monoid a) => ConduitT () a m () -> m a sinkMem c = runConduit $ c .| CL.foldMap id diff --git a/src/Lib/PkgRepository.hs b/src/Lib/PkgRepository.hs index 9c4a4e7..df331af 100644 --- a/src/Lib/PkgRepository.hs +++ b/src/Lib/PkgRepository.hs @@ -62,6 +62,7 @@ import Startlude ( ($) , MonadIO(liftIO) , MonadReader , Show + , SomeException(SomeException) , filter , find , for_ @@ -69,10 +70,12 @@ import Startlude ( ($) , headMay , not , partitionEithers + , print , pure , show , sortOn , throwIO + , void ) import System.FSNotify ( Event(Added) , eventPath @@ -89,6 +92,7 @@ import UnliftIO ( MonadUnliftIO , askRunInIO , async , mapConcurrently + , mapConcurrently_ , newEmptyMVar , onException , takeMVar @@ -101,6 +105,7 @@ import UnliftIO.Directory ( getFileSize , removeFile , renameFile ) +import UnliftIO.Exception ( handle ) import Yesod.Core.Content ( typeGif , typeJpeg , typePlain @@ -137,11 +142,10 @@ getBestVersion pkg spec = headMay . sortOn Down <$> getViableVersions pkg spec -- extract all package assets into their own respective files extractPkg :: (MonadUnliftIO m, MonadReader r m, Has PkgRepo r, MonadLoggerIO m) => FilePath -> m () -extractPkg fp = (`onException` cleanup) $ do +extractPkg fp = handle @_ @SomeException cleanup $ do $logInfo [i|Extracting package: #{fp}|] PkgRepo { pkgRepoAppMgrBin = appmgr } <- ask let pkgRoot = takeDirectory fp - -- let s9pk = pkgRoot show pkg <.> "s9pk" manifestTask <- async $ liftIO . runResourceT $ AppMgr.sourceManifest appmgr fp $ sinkIt (pkgRoot "manifest.json") pkgHashTask <- async $ AppMgr.getPackageHash appmgr fp @@ -165,11 +169,13 @@ extractPkg fp = (`onException` cleanup) $ do wait licenseTask where sinkIt fp source = runConduit $ source .| sinkFileCautious fp - cleanup = do + cleanup e = do + $logError $ show e let pkgRoot = takeDirectory fp fs <- listDirectory pkgRoot let toRemove = filter (not . (== ".s9pk") . takeExtension) fs - mapConcurrently (removeFile . (pkgRoot )) toRemove + mapConcurrently_ (removeFile . (pkgRoot )) toRemove + throwIO e watchPkgRepoRoot :: (MonadUnliftIO m, MonadReader r m, Has PkgRepo r, MonadLoggerIO m) => m (IO Bool) watchPkgRepoRoot = do @@ -181,7 +187,7 @@ 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. - runInIO (extractPkg pkg) + void . forkIO $ runInIO (extractPkg pkg) takeMVar box stop pure $ tryPutMVar box () From 98f7cfb2b81dc5caf2c44fcc658032ee85b8bcf2 Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Wed, 29 Sep 2021 11:05:07 -0600 Subject: [PATCH 34/48] clean up unused imports --- src/Foundation.hs | 2 -- src/Lib/PkgRepository.hs | 11 ++++------- 2 files changed, 4 insertions(+), 9 deletions(-) diff --git a/src/Foundation.hs b/src/Foundation.hs index 44c228c..29632a6 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -26,7 +26,6 @@ import Yesod.Core.Types ( HandlerData(handlerEnv) ) import qualified Yesod.Core.Unsafe as Unsafe -import qualified Control.Monad.Logger.Extras as Extra import Control.Monad.Logger.Extras ( wrapSGRCode ) import Control.Monad.Reader.Has ( Has(extract, update) ) import Data.String.Interpolate.IsString @@ -42,7 +41,6 @@ import System.Console.ANSI.Codes ( Color(..) , SGR(SetColor) ) import System.FilePath ( () ) -import Yesod ( defaultMessageLoggerSource ) import Yesod.Persist.Core -- | The foundation datatype for your application. This can be a good place to diff --git a/src/Lib/PkgRepository.hs b/src/Lib/PkgRepository.hs index df331af..bdbf646 100644 --- a/src/Lib/PkgRepository.hs +++ b/src/Lib/PkgRepository.hs @@ -51,18 +51,18 @@ import Startlude ( ($) , (<>) , Bool(..) , ByteString - , Down(Down) - , Either(Left, Right) + , Down(..) + , Either(..) , Eq((==)) , Exception , FilePath , IO , Integer - , Maybe(Just, Nothing) + , Maybe(..) , MonadIO(liftIO) , MonadReader , Show - , SomeException(SomeException) + , SomeException(..) , filter , find , for_ @@ -70,7 +70,6 @@ import Startlude ( ($) , headMay , not , partitionEithers - , print , pure , show , sortOn @@ -91,10 +90,8 @@ import System.FilePath ( (<.>) import UnliftIO ( MonadUnliftIO , askRunInIO , async - , mapConcurrently , mapConcurrently_ , newEmptyMVar - , onException , takeMVar , wait ) From db9d0cfb32b57deaa22226aee3c51801bc15084f Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Wed, 29 Sep 2021 11:11:51 -0600 Subject: [PATCH 35/48] remove inject function --- src/Handler/Apps.hs | 9 +-------- 1 file changed, 1 insertion(+), 8 deletions(-) diff --git a/src/Handler/Apps.hs b/src/Handler/Apps.hs index bfec546..9ba31f3 100644 --- a/src/Handler/Apps.hs +++ b/src/Handler/Apps.hs @@ -30,10 +30,8 @@ import System.FilePath ( (<.>) import System.Posix.Files ( fileSize , getFileStatus ) -import Yesod.Core ( MonadHandler(HandlerSite) - , TypedContent +import Yesod.Core ( TypedContent , addHeader - , getYesod , notFound , respondSource , sendChunkBS @@ -76,11 +74,6 @@ pureLog = liftA2 (*>) ($logInfo . show) pure logRet :: ToJSON a => Handler a -> Handler a logRet = (>>= liftA2 (*>) ($logInfo . decodeUtf8 . BS.toStrict . encode) pure) -inject :: MonadHandler m => ReaderT (HandlerSite m) m a -> m a -inject action = do - env <- getYesod - runReaderT action env - data FileExtension = FileExtension FilePath (Maybe String) instance Show FileExtension where show (FileExtension f Nothing ) = f From 779d281ea241c5df83b52f64d837ffd3b58e6e1e Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Wed, 29 Sep 2021 11:17:24 -0600 Subject: [PATCH 36/48] remove debugging code --- src/Lib/External/AppMgr.hs | 22 ++-------------------- 1 file changed, 2 insertions(+), 20 deletions(-) diff --git a/src/Lib/External/AppMgr.hs b/src/Lib/External/AppMgr.hs index 86dad17..2ae14e7 100644 --- a/src/Lib/External/AppMgr.hs +++ b/src/Lib/External/AppMgr.hs @@ -27,15 +27,7 @@ import Conduit ( (.|) import qualified Data.Conduit.List as CL import Data.Conduit.Process.Typed import GHC.IO.Exception ( IOErrorType(NoSuchThing) - , IOException - ( IOError - , ioe_description - , ioe_errno - , ioe_filename - , ioe_handle - , ioe_location - , ioe_type - ) + , IOException(ioe_description, ioe_type) ) import Lib.Error import System.FilePath ( () ) @@ -43,8 +35,6 @@ import UnliftIO ( MonadUnliftIO , catch ) import UnliftIO ( bracket ) -import UnliftIO ( finally ) -import UnliftIO.Exception ( handle ) readProcessWithExitCode' :: MonadIO m => String -> [String] -> ByteString -> m (ExitCode, ByteString, ByteString) readProcessWithExitCode' a b c = liftIO $ do @@ -66,7 +56,7 @@ readProcessInheritStderr :: forall m a -> ByteString -> (ConduitT () ByteString m () -> m a) -- this is because we can't clean up the process in the unCPS'ed version of this -> m a -readProcessInheritStderr a b c sink = handle help $ do +readProcessInheritStderr a b c sink = do let pc = setStdin (byteStringInput $ LBS.fromStrict c) $ setEnvInherit @@ -85,14 +75,6 @@ readProcessInheritStderr a b c sink = handle help $ do then pure () else throwIO e ) - help e@IOError {..} = do - print $ ioe_handle - print $ ioe_type - print $ ioe_location - print $ ioe_description - print $ ioe_errno - print $ ioe_filename - throwIO e sourceManifest :: (MonadUnliftIO m) => FilePath -> FilePath -> (ConduitT () ByteString m () -> m r) -> m r sourceManifest appmgrPath pkgFile sink = do From 2e792ddd3f45bdb8047cee57e878cb7e5871de9f Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Wed, 29 Sep 2021 11:27:46 -0600 Subject: [PATCH 37/48] Apply suggestions from code review Mostly removals of commented code. --- src/Handler/Marketplace.hs | 9 --------- src/Lib/External/AppMgr.hs | 1 + src/Settings.hs | 2 +- test/Handler/MarketplaceSpec.hs | 2 -- 4 files changed, 2 insertions(+), 12 deletions(-) diff --git a/src/Handler/Marketplace.hs b/src/Handler/Marketplace.hs index 2fac927..8f9386e 100644 --- a/src/Handler/Marketplace.hs +++ b/src/Handler/Marketplace.hs @@ -343,7 +343,6 @@ getServiceDetails settings metadata maybeVersion pkg = do packageMetadata <- case HM.lookup pkg metadata of Nothing -> throwIO $ NotFoundE [i|#{pkg} not found.|] Just m -> pure m - -- let (appsDir, appMgrDir) = (( "apps") . resourcesDir &&& staticBinDir) settings let domain = registryHostname settings version <- case maybeVersion of Nothing -> do @@ -352,8 +351,6 @@ getServiceDetails settings metadata maybeVersion pkg = do [] -> throwIO $ NotFoundE $ "no latest version found for " <> show pkg x : _ -> pure x Just v -> pure v - -- let appDir = (<> "/") . ( show version) . ( show appId) $ appsDir - -- let appExt = Extension (show appId) :: Extension "s9pk" manifest <- flip runReaderT settings $ (snd <$> getManifest pkg version) >>= \bs -> runConduit $ bs .| CL.foldMap BS.fromStrict case eitherDecode manifest of @@ -393,13 +390,7 @@ mapDependencyMetadata domain metadata (appId, depInfo) = do } ) --- decodeInstructions :: (MonadUnliftIO m, MonadHandler m, MonadThrow m) => FilePath -> FilePath -> S9PK -> m Text --- decodeInstructions appmgrPath depPath package = do --- sourceInstructions appmgrPath depPath package (\bs -> sinkMem (bs .| CT.decode CT.utf8)) --- decodeLicense :: (MonadUnliftIO m, MonadThrow m, MonadHandler m) => FilePath -> FilePath -> S9PK -> m Text --- decodeLicense appmgrPath depPath package = --- sourceLicense appmgrPath depPath package (\bs -> sinkMem (bs .| CT.decode CT.utf8)) fetchAllAppVersions :: Key SApp -> HandlerFor RegistryCtx ([VersionInfo], ReleaseNotes) fetchAllAppVersions appId = do diff --git a/src/Lib/External/AppMgr.hs b/src/Lib/External/AppMgr.hs index 2ae14e7..af87a9f 100644 --- a/src/Lib/External/AppMgr.hs +++ b/src/Lib/External/AppMgr.hs @@ -65,6 +65,7 @@ readProcessInheritStderr a b c sink = do $ System.Process.Typed.proc a b withProcessTerm' pc $ \p -> sink (getStdout p) where + -- We need this to deal with https://github.com/haskell/process/issues/215 withProcessTerm' :: (MonadUnliftIO m) => ProcessConfig stdin stdout stderr -> (Process stdin stdout stderr -> m a) diff --git a/src/Settings.hs b/src/Settings.hs index 41a6b24..eca9ddb 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -25,7 +25,7 @@ import System.FilePath ( () ) import Yesod.Default.Config2 ( configSettingsYml ) import Control.Monad.Reader.Has ( Has(extract, update) ) -import Lib.PkgRepository ( PkgRepo(PkgRepo, pkgRepoAppMgrBin, pkgRepoFileRoot) ) +import Lib.PkgRepository ( PkgRepo(..) ) import Lib.Types.Emver import Orphans.Emver ( ) -- | Runtime settings to configure this application. These settings can be diff --git a/test/Handler/MarketplaceSpec.hs b/test/Handler/MarketplaceSpec.hs index c81743f..4422caa 100644 --- a/test/Handler/MarketplaceSpec.hs +++ b/test/Handler/MarketplaceSpec.hs @@ -133,6 +133,4 @@ spec = do 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 - -- res <- runDBtest $ getServiceVersionsWithReleaseNotes "bitcoin" - -- print res print () From bf8f225d551be4544ffe5f0e859b578a822a9c87 Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Wed, 29 Sep 2021 12:06:50 -0600 Subject: [PATCH 38/48] fix type --- package.yaml | 4 ++-- src/Handler/Marketplace.hs | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/package.yaml b/package.yaml index 422dfe3..48d29fb 100644 --- a/package.yaml +++ b/package.yaml @@ -17,7 +17,7 @@ dependencies: - aeson - ansi-terminal - attoparsec - - binary + # - binary - bytestring - casing - can-i-haz @@ -47,7 +47,7 @@ dependencies: - shakespeare - template-haskell - text - - text-conversions + # - text-conversions - time - transformers - typed-process diff --git a/src/Handler/Marketplace.hs b/src/Handler/Marketplace.hs index 8f9386e..45a0219 100644 --- a/src/Handler/Marketplace.hs +++ b/src/Handler/Marketplace.hs @@ -59,7 +59,7 @@ instance ToTypedContent CategoryRes where toTypedContent = toTypedContent . toJSON data ServiceRes = ServiceRes { serviceResIcon :: URL - , serviceResManifest :: Maybe Data.Aeson.Value -- ServiceManifest + , serviceResManifest :: Data.Aeson.Value -- ServiceManifest , serviceResCategories :: [CategoryTitle] , serviceResInstructions :: URL , serviceResLicense :: URL From d77ae1d51d2097e21742234bed9e20e0637fbd01 Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Wed, 29 Sep 2021 12:12:10 -0600 Subject: [PATCH 39/48] remove commented pkg --- package.yaml | 2 -- 1 file changed, 2 deletions(-) diff --git a/package.yaml b/package.yaml index 48d29fb..b1ed290 100644 --- a/package.yaml +++ b/package.yaml @@ -17,7 +17,6 @@ dependencies: - aeson - ansi-terminal - attoparsec - # - binary - bytestring - casing - can-i-haz @@ -47,7 +46,6 @@ dependencies: - shakespeare - template-haskell - text - # - text-conversions - time - transformers - typed-process From 9980ad55a3cd36b4e0a1fa2368903223514d625f Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Wed, 29 Sep 2021 12:15:06 -0600 Subject: [PATCH 40/48] delete unused code --- src/Handler/Marketplace.hs | 41 -------------------------------------- 1 file changed, 41 deletions(-) diff --git a/src/Handler/Marketplace.hs b/src/Handler/Marketplace.hs index 45a0219..b816af0 100644 --- a/src/Handler/Marketplace.hs +++ b/src/Handler/Marketplace.hs @@ -486,47 +486,6 @@ fetchAppCategories appId = select $ do where_ (service ^. SAppId ==. val appId) pure categories -mapEntityToStoreApp :: MonadIO m => Entity SApp -> ReaderT SqlBackend m StoreApp -mapEntityToStoreApp serviceEntity = do - let service = entityVal serviceEntity - entityVersion <- fetchMostRecentAppVersions $ entityKey serviceEntity - let vers = entityVal <$> entityVersion - let vv = mapSVersionToVersionInfo vers - pure $ StoreApp { storeAppTitle = sAppTitle service - , storeAppDescShort = sAppDescShort service - , storeAppDescLong = sAppDescLong service - , storeAppVersionInfo = NE.fromList vv - , storeAppIconType = sAppIconType service - , storeAppTimestamp = Just (sAppCreatedAt service) -- case on if updatedAt? or always use updated time? was file timestamp - } - where - mapSVersionToVersionInfo :: [SVersion] -> [VersionInfo] - mapSVersionToVersionInfo sv = do - (\v -> VersionInfo { versionInfoVersion = sVersionNumber v - , versionInfoReleaseNotes = sVersionReleaseNotes v - , versionInfoDependencies = HM.empty - , versionInfoOsRequired = sVersionOsVersionRequired v - , versionInfoOsRecommended = sVersionOsVersionRecommended v - , versionInfoInstallAlert = Nothing - } - ) - <$> sv - -mapEntityToServiceAvailable :: (MonadIO m, MonadHandler m) - => Text - -> Entity SApp - -> ReaderT SqlBackend m ServiceAvailable -mapEntityToServiceAvailable domain service = do - let appId = sAppAppId $ entityVal service - (_, v) <- fetchLatestApp appId >>= errOnNothing status404 "service not found" - let appVersion = sVersionNumber (entityVal v) - pure $ ServiceAvailable { serviceAvailableId = appId - , serviceAvailableTitle = sAppTitle $ entityVal service - , serviceAvailableDescShort = sAppDescShort $ entityVal service - , serviceAvailableVersion = appVersion - , serviceAvailableIcon = [i|https://#{domain}/package/icon/#{appId}?spec==#{appVersion}|] - } - -- >>> encode hm -- "{\"0.2.0\":\"some notes\"}" hm :: Data.Aeson.Value From 2274a0cdad464d0994fc65abf251f52d2ba28895 Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Wed, 29 Sep 2021 12:55:21 -0600 Subject: [PATCH 41/48] remove postgresql-simple dependency --- package.yaml | 1 - src/Orphans/Emver.hs | 14 +++----------- 2 files changed, 3 insertions(+), 12 deletions(-) diff --git a/package.yaml b/package.yaml index b1ed290..742a24e 100644 --- a/package.yaml +++ b/package.yaml @@ -40,7 +40,6 @@ dependencies: - persistent - persistent-postgresql - persistent-template - - postgresql-simple - process - protolude - shakespeare diff --git a/src/Orphans/Emver.hs b/src/Orphans/Emver.hs index 502595f..10be872 100644 --- a/src/Orphans/Emver.hs +++ b/src/Orphans/Emver.hs @@ -9,12 +9,10 @@ import Startlude import Data.Aeson import qualified Data.Attoparsec.Text as Atto -import Lib.Types.Emver -import Database.Persist.Sql -import qualified Data.Text as T import Control.Monad.Fail ( MonadFail(fail) ) -import Database.PostgreSQL.Simple.FromField -import Database.PostgreSQL.Simple.ToField +import qualified Data.Text as T +import Database.Persist.Sql +import Lib.Types.Emver instance FromJSON Version where parseJSON = withText "Emver Version" $ either fail pure . Atto.parseOnly parseVersion @@ -35,9 +33,3 @@ instance PersistField VersionRange where fromPersistValue = first T.pack . Atto.parseOnly parseRange <=< fromPersistValue instance PersistFieldSql VersionRange where sqlType _ = SqlString -instance FromField Version where - fromField a = fromJSONField a -instance FromField [Version] where - fromField a = fromJSONField a -instance ToField [Version] where - toField a = toJSONField a \ No newline at end of file From 8871edc1ee60095366b9206c2aa404c1a660af86 Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Wed, 29 Sep 2021 13:17:42 -0600 Subject: [PATCH 42/48] remove prelude import --- src/Handler/Marketplace.hs | 1 - src/Lib/Types/Emver.hs | 47 +++++++++++++++++--------------------- 2 files changed, 21 insertions(+), 27 deletions(-) diff --git a/src/Handler/Marketplace.hs b/src/Handler/Marketplace.hs index b816af0..416f63a 100644 --- a/src/Handler/Marketplace.hs +++ b/src/Handler/Marketplace.hs @@ -19,7 +19,6 @@ import qualified Data.ByteString.Lazy as BS import qualified Data.Conduit.List as CL import qualified Data.HashMap.Strict as HM import Data.List -import qualified Data.List.NonEmpty as NE import Data.Semigroup import Data.String.Interpolate.IsString import qualified Data.Text as T diff --git a/src/Lib/Types/Emver.hs b/src/Lib/Types/Emver.hs index 014595a..88d4b2f 100644 --- a/src/Lib/Types/Emver.hs +++ b/src/Lib/Types/Emver.hs @@ -36,25 +36,24 @@ module Lib.Types.Emver , parseRange ) where -import Control.Applicative ( Alternative((<|>)) - , liftA2 - ) +import Startlude hiding ( Any ) + +import Control.Monad.Fail ( fail ) import Data.Aeson import qualified Data.Attoparsec.Text as Atto -import Data.Function -import Data.Functor ( ($>) - , (<&>) - ) -import Data.String ( IsString(..) ) import qualified Data.Text as T -import Prelude -import Startlude ( Hashable ) +import GHC.Base ( error ) +import qualified GHC.Read as GHC + ( readsPrec ) +import qualified GHC.Show as GHC + ( show ) -- | AppVersion is the core representation of the SemverQuad type. newtype Version = Version { unVersion :: (Word, Word, Word, Word) } deriving (Eq, Ord, ToJSONKey, Hashable) instance Show Version where show (Version (x, y, z, q)) = - let postfix = if q == 0 then "" else '.' : show q in show x <> "." <> show y <> "." <> show z <> postfix + let postfix = if q == 0 then "" else '.' : GHC.show q + in GHC.show x <> "." <> GHC.show y <> "." <> GHC.show z <> postfix instance IsString Version where fromString s = either error id $ Atto.parseOnly parseVersion (T.pack s) instance Read Version where @@ -134,17 +133,17 @@ exactly :: Version -> VersionRange exactly = Anchor (Right EQ) instance Show VersionRange where - show (Anchor ( Left EQ) v ) = '!' : '=' : show v - show (Anchor ( Right EQ) v ) = '=' : show v - show (Anchor ( Left LT) v ) = '>' : '=' : show v - show (Anchor ( Right LT) v ) = '<' : show v - show (Anchor ( Left GT) v ) = '<' : '=' : show v - show (Anchor ( Right GT) v ) = '>' : show v - show (Conj a@(Disj _ _) b@(Disj _ _)) = paren (show a) <> (' ' : paren (show b)) - show (Conj a@(Disj _ _) b ) = paren (show a) <> (' ' : show b) - show (Conj a b@(Disj _ _)) = show a <> (' ' : paren (show b)) - show (Conj a b ) = show a <> (' ' : show b) - show (Disj a b ) = show a <> " || " <> show b + show (Anchor ( Left EQ) v ) = '!' : '=' : GHC.show v + show (Anchor ( Right EQ) v ) = '=' : GHC.show v + show (Anchor ( Left LT) v ) = '>' : '=' : GHC.show v + show (Anchor ( Right LT) v ) = '<' : GHC.show v + show (Anchor ( Left GT) v ) = '<' : '=' : GHC.show v + show (Anchor ( Right GT) v ) = '>' : GHC.show v + show (Conj a@(Disj _ _) b@(Disj _ _)) = paren (GHC.show a) <> (' ' : paren (GHC.show b)) + show (Conj a@(Disj _ _) b ) = paren (GHC.show a) <> (' ' : GHC.show b) + show (Conj a b@(Disj _ _)) = GHC.show a <> (' ' : paren (GHC.show b)) + show (Conj a b ) = GHC.show a <> (' ' : GHC.show b) + show (Disj a b ) = GHC.show a <> " || " <> GHC.show b show Any = "*" show None = "!" instance Read VersionRange where @@ -183,10 +182,6 @@ satisfies _ None = False (||>) = flip satisfies {-# INLINE (||>) #-} -(<<$>>) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b) -(<<$>>) = fmap . fmap -{-# INLINE (<<$>>) #-} - parseOperator :: Atto.Parser Operator parseOperator = (Atto.char '=' $> Right EQ) From 056e04f4e30cd211df0ac286cbfefd5fa7718828 Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Wed, 29 Sep 2021 13:22:39 -0600 Subject: [PATCH 43/48] also re-extract if file modified --- src/Lib/PkgRepository.hs | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/src/Lib/PkgRepository.hs b/src/Lib/PkgRepository.hs index bdbf646..81cae20 100644 --- a/src/Lib/PkgRepository.hs +++ b/src/Lib/PkgRepository.hs @@ -76,7 +76,8 @@ import Startlude ( ($) , throwIO , void ) -import System.FSNotify ( Event(Added) +import System.FSNotify ( ActionPredicate + , Event(..) , eventPath , watchTree , withManager @@ -189,9 +190,11 @@ watchPkgRepoRoot = do stop pure $ tryPutMVar box () where - onlyAdded = \case - Added path _ isDir -> not isDir && takeExtension path == ".s9pk" - _ -> False + onlyAdded :: ActionPredicate + onlyAdded (Added path _ isDir) = not isDir && takeExtension path == ".s9pk" + onlyAdded (Modified path _ isDir) = not isDir && takeExtension path == ".s9pk" + onlyAdded _ = False + -- Added path _ isDir -> not isDir && takeExtension path == ".s9pk" getManifest :: (MonadResource m, MonadReader r m, Has PkgRepo r) => PkgId From b949eafbfa7b38c4854a2ccc23909e8c042f2997 Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Wed, 29 Sep 2021 13:29:02 -0600 Subject: [PATCH 44/48] changed prints to logs --- src/Lib/External/AppMgr.hs | 42 ++++++++++++++++++++++++++------------ src/Lib/PkgRepository.hs | 9 ++++---- 2 files changed, 33 insertions(+), 18 deletions(-) diff --git a/src/Lib/External/AppMgr.hs b/src/Lib/External/AppMgr.hs index af87a9f..0db98bc 100644 --- a/src/Lib/External/AppMgr.hs +++ b/src/Lib/External/AppMgr.hs @@ -7,6 +7,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TemplateHaskell #-} module Lib.External.AppMgr where @@ -24,6 +25,9 @@ import Conduit ( (.|) , ConduitT , runConduit ) +import Control.Monad.Logger ( MonadLoggerIO + , logErrorSH + ) import qualified Data.Conduit.List as CL import Data.Conduit.Process.Typed import GHC.IO.Exception ( IOErrorType(NoSuchThing) @@ -77,35 +81,47 @@ readProcessInheritStderr a b c sink = do else throwIO e ) -sourceManifest :: (MonadUnliftIO m) => FilePath -> FilePath -> (ConduitT () ByteString m () -> m r) -> m r +sourceManifest :: (MonadUnliftIO m, MonadLoggerIO m) + => FilePath + -> FilePath + -> (ConduitT () ByteString m () -> m r) + -> m r sourceManifest appmgrPath pkgFile sink = do let appmgr = readProcessInheritStderr (appmgrPath "embassy-sdk") ["inspect", "manifest", pkgFile] "" appmgr sink `catch` \ece -> - print ece *> throwIO (AppMgrE [i|embassy-sdk inspect manifest #{pkgFile}|] (eceExitCode ece)) + $logErrorSH ece *> throwIO (AppMgrE [i|embassy-sdk inspect manifest #{pkgFile}|] (eceExitCode ece)) -sourceIcon :: (MonadUnliftIO m) => FilePath -> FilePath -> (ConduitT () ByteString m () -> m r) -> m r +sourceIcon :: (MonadUnliftIO m, MonadLoggerIO m) => FilePath -> FilePath -> (ConduitT () ByteString m () -> m r) -> m r sourceIcon appmgrPath pkgFile sink = do let appmgr = readProcessInheritStderr (appmgrPath "embassy-sdk") ["inspect", "icon", pkgFile] "" - appmgr sink - `catch` \ece -> print ece *> throwIO (AppMgrE [i|embassy-sdk inspect icon #{pkgFile}|] (eceExitCode ece)) + appmgr sink `catch` \ece -> + $logErrorSH ece *> throwIO (AppMgrE [i|embassy-sdk inspect icon #{pkgFile}|] (eceExitCode ece)) -getPackageHash :: (MonadUnliftIO m) => FilePath -> FilePath -> m ByteString +getPackageHash :: (MonadUnliftIO m, MonadLoggerIO m) => FilePath -> FilePath -> m ByteString getPackageHash appmgrPath pkgFile = do let appmgr = readProcessInheritStderr (appmgrPath "embassy-sdk") ["inspect", "hash", pkgFile] "" - appmgr (\bsSource -> runConduit $ bsSource .| CL.foldMap id) - `catch` \ece -> print ece *> throwIO (AppMgrE [i|embassy-sdk inspect hash #{pkgFile}|] (eceExitCode ece)) + appmgr (\bsSource -> runConduit $ bsSource .| CL.foldMap id) `catch` \ece -> + $logErrorSH ece *> throwIO (AppMgrE [i|embassy-sdk inspect hash #{pkgFile}|] (eceExitCode ece)) -sourceInstructions :: (MonadUnliftIO m) => FilePath -> FilePath -> (ConduitT () ByteString m () -> m r) -> m r +sourceInstructions :: (MonadUnliftIO m, MonadLoggerIO m) + => FilePath + -> FilePath + -> (ConduitT () ByteString m () -> m r) + -> m r sourceInstructions appmgrPath pkgFile sink = do let appmgr = readProcessInheritStderr (appmgrPath "embassy-sdk") ["inspect", "instructions", pkgFile] "" appmgr sink `catch` \ece -> - print ece *> throwIO (AppMgrE [i|embassy-sdk inspect instructions #{pkgFile}|] (eceExitCode ece)) + $logErrorSH ece *> throwIO (AppMgrE [i|embassy-sdk inspect instructions #{pkgFile}|] (eceExitCode ece)) -sourceLicense :: (MonadUnliftIO m) => FilePath -> FilePath -> (ConduitT () ByteString m () -> m r) -> m r +sourceLicense :: (MonadUnliftIO m, MonadLoggerIO m) + => FilePath + -> FilePath + -> (ConduitT () ByteString m () -> m r) + -> m r sourceLicense appmgrPath pkgFile sink = do let appmgr = readProcessInheritStderr (appmgrPath "embassy-sdk") ["inspect", "license", pkgFile] "" - appmgr sink - `catch` \ece -> print ece *> throwIO (AppMgrE [i|embassy-sdk inspect license #{pkgFile}|] (eceExitCode ece)) + appmgr sink `catch` \ece -> + $logErrorSH ece *> throwIO (AppMgrE [i|embassy-sdk inspect license #{pkgFile}|] (eceExitCode ece)) sinkMem :: (Monad m, Monoid a) => ConduitT () a m () -> m a sinkMem c = runConduit $ c .| CL.foldMap id diff --git a/src/Lib/PkgRepository.hs b/src/Lib/PkgRepository.hs index 81cae20..d0ede79 100644 --- a/src/Lib/PkgRepository.hs +++ b/src/Lib/PkgRepository.hs @@ -144,13 +144,12 @@ extractPkg fp = handle @_ @SomeException cleanup $ do $logInfo [i|Extracting package: #{fp}|] PkgRepo { pkgRepoAppMgrBin = appmgr } <- ask let pkgRoot = takeDirectory fp - manifestTask <- async $ liftIO . runResourceT $ AppMgr.sourceManifest appmgr fp $ sinkIt - (pkgRoot "manifest.json") + manifestTask <- async $ runResourceT $ AppMgr.sourceManifest appmgr fp $ sinkIt (pkgRoot "manifest.json") pkgHashTask <- async $ AppMgr.getPackageHash appmgr fp - instructionsTask <- async $ liftIO . runResourceT $ AppMgr.sourceInstructions appmgr fp $ sinkIt + instructionsTask <- async $ runResourceT $ AppMgr.sourceInstructions appmgr fp $ sinkIt (pkgRoot "instructions.md") - licenseTask <- async $ liftIO . runResourceT $ AppMgr.sourceLicense appmgr fp $ sinkIt (pkgRoot "license.md") - iconTask <- async $ liftIO . runResourceT $ AppMgr.sourceIcon appmgr fp $ sinkIt (pkgRoot "icon.tmp") + licenseTask <- async $ runResourceT $ AppMgr.sourceLicense appmgr fp $ sinkIt (pkgRoot "license.md") + iconTask <- async $ runResourceT $ AppMgr.sourceIcon appmgr fp $ sinkIt (pkgRoot "icon.tmp") wait manifestTask eManifest <- liftIO (eitherDecodeFileStrict' (pkgRoot "manifest.json")) case eManifest of From 93f8c7be2426fb5e17e9a8523ae9f98bdebf66df Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Wed, 29 Sep 2021 13:30:27 -0600 Subject: [PATCH 45/48] Apply suggestions from code review Remove unused code Co-authored-by: Lucy C <12953208+elvece@users.noreply.github.com> --- src/Handler/Apps.hs | 5 ----- 1 file changed, 5 deletions(-) diff --git a/src/Handler/Apps.hs b/src/Handler/Apps.hs index 9ba31f3..972bd3a 100644 --- a/src/Handler/Apps.hs +++ b/src/Handler/Apps.hs @@ -112,11 +112,6 @@ getAppR file = do addHeader "Content-Length" (show len) respondSource typeOctet $ src .| awaitForever sendChunkBS -chunkIt :: FilePath -> Handler TypedContent -chunkIt fp = do - sz <- liftIO $ fileSize <$> getFileStatus fp - addHeader "Content-Length" (show sz) - respondSource typeOctet $ CB.sourceFile fp .| awaitForever sendChunkBS recordMetrics :: PkgId -> Version -> Handler () recordMetrics pkg appVersion = do From 605392f0758ca0f8de50b688064a47b24ec24f8b Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Wed, 29 Sep 2021 14:00:49 -0600 Subject: [PATCH 46/48] reduce io dependence --- package.yaml | 1 + src/Handler/Apps.hs | 4 - src/Handler/Marketplace.hs | 177 ++++++++++++++++++++++++++----------- src/Lib/Error.hs | 13 +-- 4 files changed, 135 insertions(+), 60 deletions(-) diff --git a/package.yaml b/package.yaml index 742a24e..c24e96c 100644 --- a/package.yaml +++ b/package.yaml @@ -37,6 +37,7 @@ dependencies: - lens - monad-logger - monad-logger-extras + - parallel - persistent - persistent-postgresql - persistent-template diff --git a/src/Handler/Apps.hs b/src/Handler/Apps.hs index 972bd3a..ea8912b 100644 --- a/src/Handler/Apps.hs +++ b/src/Handler/Apps.hs @@ -19,7 +19,6 @@ import Data.Aeson ( ToJSON ) import qualified Data.Attoparsec.Text as Atto import qualified Data.ByteString.Lazy as BS -import qualified Data.Conduit.Binary as CB import qualified Data.Text as T import Database.Persist ( Entity(entityKey) ) import qualified GHC.Show ( Show(..) ) @@ -27,9 +26,6 @@ import Network.HTTP.Types ( status404 ) import System.FilePath ( (<.>) , takeBaseName ) -import System.Posix.Files ( fileSize - , getFileStatus - ) import Yesod.Core ( TypedContent , addHeader , notFound diff --git a/src/Handler/Marketplace.hs b/src/Handler/Marketplace.hs index 416f63a..f82d639 100644 --- a/src/Handler/Marketplace.hs +++ b/src/Handler/Marketplace.hs @@ -11,40 +11,117 @@ {-# LANGUAGE DeriveAnyClass #-} module Handler.Marketplace where -import Conduit ( (.|) - , runConduit - ) -import Data.Aeson -import qualified Data.ByteString.Lazy as BS -import qualified Data.Conduit.List as CL -import qualified Data.HashMap.Strict as HM -import Data.List -import Data.Semigroup -import Data.String.Interpolate.IsString -import qualified Data.Text as T -import Database.Esqueleto.Experimental -import Database.Esqueleto.PostgreSQL ( arrayAggDistinct ) -import Database.Marketplace -import qualified Database.Persist as P -import Foundation -import Lib.Error -import Lib.PkgRepository ( getManifest ) -import Lib.Types.AppIndex -import Lib.Types.AppIndex ( ) -import Lib.Types.Category -import Lib.Types.Emver -import Model -import Network.HTTP.Types -import Protolude.Unsafe ( unsafeFromJust ) -import Settings + import Startlude hiding ( Handler , from , on , sortOn ) -import UnliftIO.Async -import Yesod.Core -import Yesod.Persist.Core + +import Conduit ( (.|) + , runConduit + ) +import Control.Monad.Except.CoHas ( liftEither ) +import Control.Parallel.Strategies ( parMap + , rpar + ) +import Data.Aeson ( (.:) + , FromJSON(parseJSON) + , KeyValue((.=)) + , ToJSON(toJSON) + , Value(String) + , decode + , eitherDecode + , eitherDecodeStrict + , object + , withObject + ) +import qualified Data.ByteString.Lazy as BS +import qualified Data.Conduit.List as CL +import qualified Data.HashMap.Strict as HM +import Data.List ( head + , lookup + , sortOn + ) +import Data.Semigroup ( Max(Max, getMax) ) +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 + , innerJoin + , just + , leftJoin + , limit + , on + , orderBy + , select + , selectOne + , table + , val + , where_ + ) +import Database.Esqueleto.PostgreSQL ( arrayAggDistinct ) +import Database.Marketplace ( searchServices ) +import qualified Database.Persist as P +import Foundation ( Handler + , RegistryCtx(appSettings) + ) +import Lib.Error ( S9Error(AssetParseE, InvalidParamsE, NotFoundE) + , errOnNothing + ) +import Lib.PkgRepository ( getManifest ) +import Lib.Types.AppIndex ( PkgId(PkgId) + , ServiceDependencyInfo(serviceDependencyInfoVersion) + , ServiceManifest(serviceManifestDependencies) + , VersionInfo(..) + ) +import Lib.Types.AppIndex ( ) +import Lib.Types.Category ( CategoryTitle(FEATURED) ) +import Lib.Types.Emver ( (<||) + , Version + , VersionRange + ) +import Model ( Category(..) + , EntityField(..) + , OsVersion(..) + , SApp(..) + , SVersion(..) + , ServiceCategory + ) +import Network.HTTP.Types ( status400 + , status404 + ) +import Protolude.Unsafe ( unsafeFromJust ) +import Settings ( AppSettings(registryHostname) ) +import UnliftIO.Async ( concurrently + , mapConcurrently + ) +import Yesod.Core ( HandlerFor + , MonadLogger + , MonadResource + , MonadUnliftIO + , ToContent(..) + , ToTypedContent(..) + , YesodRequest(..) + , getRequest + , getsYesod + , logWarn + , lookupGetParam + , sendResponseStatus + ) +import Yesod.Persist.Core ( YesodPersist(runDB) ) type URL = Text newtype CategoryRes = CategoryRes { @@ -332,57 +409,55 @@ getPackageListR = do Just v -> do pure $ Right (Just v, appId) -getServiceDetails :: (MonadUnliftIO m, Monad m, MonadResource m) +getServiceDetails :: (MonadIO m, MonadResource m) => AppSettings -> (HM.HashMap PkgId ([Version], [CategoryTitle])) -> Maybe Version -> PkgId - -> m (Either Text ServiceRes) -getServiceDetails settings metadata maybeVersion pkg = do + -> m (Either S9Error ServiceRes) +getServiceDetails settings metadata maybeVersion pkg = runExceptT $ do packageMetadata <- case HM.lookup pkg metadata of - Nothing -> throwIO $ NotFoundE [i|#{pkg} not found.|] + Nothing -> liftEither . Left $ NotFoundE [i|#{pkg} not found.|] Just m -> pure m let domain = registryHostname settings version <- case maybeVersion of Nothing -> do -- grab first value, which will be the latest version case fst packageMetadata of - [] -> throwIO $ NotFoundE $ "no latest version found for " <> show pkg + [] -> liftEither . Left $ NotFoundE $ "no latest version found for " <> show pkg x : _ -> pure x Just v -> pure v manifest <- flip runReaderT settings $ (snd <$> getManifest pkg version) >>= \bs -> runConduit $ bs .| CL.foldMap BS.fromStrict case eitherDecode manifest of - Left e -> pure $ Left $ "Could not parse service manifest for " <> show pkg <> ": " <> show e + Left _ -> liftEither . Left $ AssetParseE [i|#{pkg}:manifest|] (decodeUtf8 $ BS.toStrict manifest) Right m -> do - d <- liftIO $ mapConcurrently (mapDependencyMetadata domain metadata) - (HM.toList $ serviceManifestDependencies m) - pure $ Right $ ServiceRes { serviceResIcon = [i|https://#{domain}/package/icon/#{pkg}|] + let d = parMap rpar (mapDependencyMetadata domain metadata) (HM.toList $ serviceManifestDependencies m) + pure $ ServiceRes { serviceResIcon = [i|https://#{domain}/package/icon/#{pkg}|] -- pass through raw JSON Value, we have checked its correct parsing above - , serviceResManifest = unsafeFromJust . decode $ manifest - , serviceResCategories = snd packageMetadata - , serviceResInstructions = [i|https://#{domain}/package/instructions/#{pkg}|] - , serviceResLicense = [i|https://#{domain}/package/license/#{pkg}|] - , serviceResVersions = fst packageMetadata - , serviceResDependencyInfo = HM.fromList $ snd $ partitionEithers d - } + , serviceResManifest = unsafeFromJust . decode $ manifest + , serviceResCategories = snd packageMetadata + , serviceResInstructions = [i|https://#{domain}/package/instructions/#{pkg}|] + , serviceResLicense = [i|https://#{domain}/package/license/#{pkg}|] + , serviceResVersions = fst packageMetadata + , serviceResDependencyInfo = HM.fromList $ snd $ partitionEithers d + } -mapDependencyMetadata :: (MonadIO m) - => Text +mapDependencyMetadata :: Text -> HM.HashMap PkgId ([Version], [CategoryTitle]) -> (PkgId, ServiceDependencyInfo) - -> m (Either Text (PkgId, DependencyInfo)) + -> Either S9Error (PkgId, DependencyInfo) mapDependencyMetadata domain metadata (appId, depInfo) = do depMetadata <- case HM.lookup appId metadata of - Nothing -> throwIO $ NotFoundE [i|dependency metadata for #{appId} not found.|] + Nothing -> Left $ NotFoundE [i|dependency metadata for #{appId} not found.|] Just m -> pure m -- get best version from VersionRange of dependency let satisfactory = filter (<|| serviceDependencyInfoVersion depInfo) (fst depMetadata) let best = getMax <$> foldMap (Just . Max) satisfactory version <- case best of - Nothing -> throwIO $ NotFoundE $ "best version not found for dependent package " <> show appId + Nothing -> Left $ NotFoundE $ "best version not found for dependent package " <> show appId Just v -> pure v - pure $ Right + pure ( appId , DependencyInfo { dependencyInfoTitle = appId , dependencyInfoIcon = [i|https://#{domain}/package/icon/#{appId}?spec==#{version}|] diff --git a/src/Lib/Error.hs b/src/Lib/Error.hs index 4e73dbc..7a6b0c7 100644 --- a/src/Lib/Error.hs +++ b/src/Lib/Error.hs @@ -16,6 +16,7 @@ data S9Error = | AppMgrE Text ExitCode | NotFoundE Text | InvalidParamsE Text Text + | AssetParseE Text Text deriving (Show, Eq) instance Exception S9Error @@ -23,17 +24,18 @@ instance Exception S9Error -- | Redact any sensitive data in this function toError :: S9Error -> Error toError = \case - PersistentE t -> Error DATABASE_ERROR t - AppMgrE cmd code -> Error APPMGR_ERROR [i|"appmgr #{cmd}" exited with #{code}|] - NotFoundE e -> Error NOT_FOUND [i|#{e}|] - InvalidParamsE e m -> Error INVALID_PARAMS [i|Could not parse request parameters #{e}: #{m}|] + PersistentE t -> Error DATABASE_ERROR t + AppMgrE cmd code -> Error APPMGR_ERROR [i|"appmgr #{cmd}" exited with #{code}|] + NotFoundE e -> Error NOT_FOUND [i|#{e}|] + InvalidParamsE e m -> Error INVALID_PARAMS [i|Could not parse request parameters #{e}: #{m}|] + AssetParseE asset found -> Error PARSE_ERROR [i|Could not parse #{asset}: #{found}|] data ErrorCode = DATABASE_ERROR | APPMGR_ERROR | NOT_FOUND | INVALID_PARAMS - + | PARSE_ERROR deriving (Eq, Show) instance ToJSON ErrorCode where toJSON = String . show @@ -61,6 +63,7 @@ toStatus = \case AppMgrE _ _ -> status500 NotFoundE _ -> status404 InvalidParamsE _ _ -> status400 + AssetParseE _ _ -> status500 handleS9ErrT :: MonadHandler m => S9ErrT m a -> m a From 6c55244aa49f19fddf35025595c6c270942243d7 Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Wed, 29 Sep 2021 14:11:51 -0600 Subject: [PATCH 47/48] send back release notes for eos --- src/Handler/Version.hs | 21 ++++++++++++++++++--- 1 file changed, 18 insertions(+), 3 deletions(-) diff --git a/src/Handler/Version.hs b/src/Handler/Version.hs index 100aa53..4e0a1ac 100644 --- a/src/Handler/Version.hs +++ b/src/Handler/Version.hs @@ -15,17 +15,20 @@ import qualified Data.Attoparsec.Text as Atto import Data.String.Interpolate.IsString ( i ) import qualified Data.Text as T +import qualified Data.Text.IO as T import Foundation import Handler.Types.Status import Lib.Error ( S9Error(NotFoundE) ) import Lib.PkgRepository ( getBestVersion ) import Lib.Types.AppIndex ( PkgId ) -import Lib.Types.Emver ( parseVersion +import Lib.Types.Emver ( Version(..) + , parseVersion , satisfies ) import Network.HTTP.Types.Status ( status404 ) import Settings import System.FilePath ( () ) +import System.IO.Error ( isDoesNotExistError ) import UnliftIO.Directory ( listDirectory ) import Util.Shared ( getVersionSpecFromQuery , orThrow @@ -41,7 +44,13 @@ getPkgVersionR pkg = do status404 (NotFoundE [i|Version for #{pkg} satisfying #{spec}|]) -getEosVersionR :: Handler AppVersionRes + +data EosVersionRes = EosVersionRes + { eosVersionVersion :: Version + , eosVersionReleaseNotes :: Text + } + +getEosVersionR :: Handler EosVersionRes getEosVersionR = do spec <- getVersionSpecFromQuery root <- getsYesod $ ( "eos") . resourcesDir . appSettings @@ -49,4 +58,10 @@ getEosVersionR = do let (failures, successes) = partitionEithers $ (Atto.parseOnly parseVersion . T.pack) <$> subdirs for_ failures $ \f -> $logWarn [i|Emver Parse Failure for EOS: #{f}|] let res = headMay . sortOn Down . filter (`satisfies` spec) $ successes - maybe (sendResponseStatus status404 (NotFoundE [i|EOS version satisfying #{spec}|])) (pure . AppVersionRes) res + case res of + Nothing -> sendResponseStatus status404 (NotFoundE [i|EOS version satisfying #{spec}|]) + Just r -> do + let notesPath = root show r "release-notes.md" + notes <- liftIO $ T.readFile notesPath `catch` \e -> + if isDoesNotExistError e then pure [i|# Release Notes Missing for #{r}|] else throwIO e + pure $ EosVersionRes r notes From 1a43fc52b626e8cc50001a93bb44cebd169a79fc Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Wed, 29 Sep 2021 14:57:06 -0600 Subject: [PATCH 48/48] more cleanup --- src/Application.hs | 22 +++++++++------ src/Handler/Apps.hs | 4 +-- src/Handler/Marketplace.hs | 57 ++++++++++++++++++++++++++++---------- src/Handler/Version.hs | 32 --------------------- src/Lib/PkgRepository.hs | 3 +- src/Lib/Types/AppIndex.hs | 2 +- 6 files changed, 60 insertions(+), 60 deletions(-) diff --git a/src/Application.hs b/src/Application.hs index cb1d049..ffa7c46 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -29,7 +29,8 @@ module Application import Startlude hiding ( Handler ) -import Control.Monad.Logger ( liftLoc +import Control.Monad.Logger ( LoggingT + , liftLoc , runLoggingT ) import Data.Default @@ -80,6 +81,8 @@ import Yesod.Default.Config2 import Control.Arrow ( (***) ) import Control.Lens import Data.List ( lookup ) +import Data.String.Interpolate.IsString + ( i ) import Database.Persist.Sql ( SqlBackend ) import Foundation import Handler.Apps @@ -268,21 +271,24 @@ startApp :: RegistryCtx -> IO () startApp foundation = do when (sslAuto . appSettings $ foundation) $ do -- set up ssl certificates - putStrLn @Text "Setting up SSL" + runLog $ $logInfo "Setting up SSL" _ <- setupSsl $ appSettings foundation - putStrLn @Text "SSL Setup Complete" + runLog $ $logInfo "SSL Setup Complete" -- certbot renew loop void . forkIO $ forever $ flip runReaderT foundation $ do shouldRenew <- doesSslNeedRenew - putStrLn @Text $ "Checking if SSL Certs should be renewed: " <> show shouldRenew + runLog $ $logInfo $ [i|Checking if SSL Certs should be renewed: #{shouldRenew}|] when shouldRenew $ do - putStrLn @Text "Renewing SSL Certs." + runLog $ $logInfo "Renewing SSL Certs." renewSslCerts liftIO $ restartWeb foundation liftIO $ sleep 86_400 startWeb foundation + where + runLog :: MonadIO m => LoggingT m a -> m a + runLog a = runLoggingT a (messageLoggerSource foundation (appLogger foundation)) startWeb :: RegistryCtx -> IO () startWeb foundation = do @@ -291,9 +297,9 @@ startWeb foundation = do where startWeb' app = (`onException` (appStopFsNotify foundation)) $ do let AppSettings {..} = appSettings foundation - runLog $ $logInfo $ "Launching Tor Web Server on port " <> show torPort + runLog $ $logInfo $ [i|Launching Tor Web Server on port #{torPort}|] torAction <- async $ runSettings (warpSettings torPort foundation) app - runLog $ $logInfo $ "Launching Web Server on port " <> show appPort + runLog $ $logInfo $ [i|Launching Web Server on port #{appPort}|] action <- if sslAuto then async $ runTLS (tlsSettings sslCertLocation sslKeyLocation) (warpSettings appPort foundation) app else async $ runSettings (warpSettings appPort foundation) app @@ -314,7 +320,7 @@ startWeb foundation = do shouldRestart <- takeMVar (appShouldRestartWeb foundation) when shouldRestart $ do putMVar (appShouldRestartWeb foundation) False - putStrLn @Text "Restarting Web Server" + runLog $ $logInfo "Restarting Web Server" startWeb' app runLog a = runLoggingT a (messageLoggerSource foundation (appLogger foundation)) diff --git a/src/Handler/Apps.hs b/src/Handler/Apps.hs index ea8912b..7ef0b06 100644 --- a/src/Handler/Apps.hs +++ b/src/Handler/Apps.hs @@ -114,14 +114,14 @@ recordMetrics pkg appVersion = do sa <- runDB $ fetchApp $ pkg case sa of Nothing -> do - $logError $ show pkg <> " not found in database" + $logError $ [i|#{pkg} not found in database|] notFound Just a -> do let appKey' = entityKey a existingVersion <- runDB $ fetchAppVersion appVersion appKey' case existingVersion of Nothing -> do - $logError $ "Version: " <> show appVersion <> " not found in database" + $logError $ [i|#{pkg}@#{appVersion} not found in database|] notFound Just v -> runDB $ createMetric (entityKey a) (entityKey v) diff --git a/src/Handler/Marketplace.hs b/src/Handler/Marketplace.hs index f82d639..f1df3e2 100644 --- a/src/Handler/Marketplace.hs +++ b/src/Handler/Marketplace.hs @@ -19,7 +19,9 @@ import Startlude hiding ( Handler ) import Conduit ( (.|) + , awaitForever , runConduit + , sourceFile ) import Control.Monad.Except.CoHas ( liftEither ) import Control.Parallel.Strategies ( parMap @@ -36,6 +38,7 @@ import Data.Aeson ( (.:) , object , withObject ) +import qualified Data.Attoparsec.Text as Atto import qualified Data.ByteString.Lazy as BS import qualified Data.Conduit.List as CL import qualified Data.HashMap.Strict as HM @@ -78,9 +81,7 @@ import qualified Database.Persist as P import Foundation ( Handler , RegistryCtx(appSettings) ) -import Lib.Error ( S9Error(AssetParseE, InvalidParamsE, NotFoundE) - , errOnNothing - ) +import Lib.Error ( S9Error(..) ) import Lib.PkgRepository ( getManifest ) import Lib.Types.AppIndex ( PkgId(PkgId) , ServiceDependencyInfo(serviceDependencyInfoVersion) @@ -92,6 +93,8 @@ import Lib.Types.Category ( CategoryTitle(FEATURED) ) import Lib.Types.Emver ( (<||) , Version , VersionRange + , parseVersion + , satisfies ) import Model ( Category(..) , EntityField(..) @@ -104,22 +107,31 @@ import Network.HTTP.Types ( status400 , status404 ) import Protolude.Unsafe ( unsafeFromJust ) -import Settings ( AppSettings(registryHostname) ) +import Settings ( AppSettings(registryHostname, resourcesDir) ) +import System.FilePath ( () ) import UnliftIO.Async ( concurrently , mapConcurrently ) +import UnliftIO.Directory ( listDirectory ) +import Util.Shared ( getVersionSpecFromQuery + , orThrow + ) import Yesod.Core ( HandlerFor , MonadLogger , MonadResource , MonadUnliftIO , ToContent(..) , ToTypedContent(..) + , TypedContent , YesodRequest(..) , getRequest , getsYesod , logWarn , lookupGetParam + , respondSource + , sendChunkBS , sendResponseStatus + , typeOctet ) import Yesod.Persist.Core ( YesodPersist(runDB) ) @@ -266,8 +278,8 @@ getCategoriesR = do pure cats pure $ CategoryRes $ categoryName . entityVal <$> allCategories -getEosR :: Handler EosRes -getEosR = do +getEosVersionR :: Handler EosRes +getEosVersionR = do allEosVersions <- runDB $ select $ do vers <- from $ table @OsVersion orderBy [desc (vers ^. OsVersionCreatedAt)] @@ -289,19 +301,35 @@ getReleaseNotesR :: Handler ReleaseNotes getReleaseNotesR = do getParameters <- reqGetParams <$> getRequest case lookup "id" getParameters of - Nothing -> sendResponseStatus status400 ("expected query param \"id\" to exist" :: Text) + Nothing -> sendResponseStatus status400 (InvalidParamsE "get:id" "") Just package -> do - (service, _) <- runDB $ fetchLatestApp (PkgId package) >>= errOnNothing status404 "package not found" + (service, _) <- runDB $ fetchLatestApp (PkgId package) `orThrow` sendResponseStatus + status404 + (NotFoundE $ show package) (_, mappedVersions) <- fetchAllAppVersions (entityKey service) pure mappedVersions +getEosR :: Handler TypedContent +getEosR = do + spec <- getVersionSpecFromQuery + root <- getsYesod $ ( "eos") . resourcesDir . appSettings + subdirs <- listDirectory root + let (failures, successes) = partitionEithers $ (Atto.parseOnly parseVersion . T.pack) <$> subdirs + for_ failures $ \f -> $logWarn [i|Emver Parse Failure for EOS: #{f}|] + let res = headMay . sortOn Down . filter (`satisfies` spec) $ successes + case res of + Nothing -> sendResponseStatus status404 (NotFoundE [i|EOS version satisfying #{spec}|]) + Just r -> do + let imgPath = root show r "eos.img" + respondSource typeOctet (sourceFile imgPath .| awaitForever sendChunkBS) + getVersionLatestR :: Handler VersionLatestRes getVersionLatestR = do getParameters <- reqGetParams <$> getRequest case lookup "ids" getParameters of - Nothing -> sendResponseStatus status400 ("expected query param \"ids\" to exist" :: Text) + Nothing -> sendResponseStatus status400 (InvalidParamsE "get:ids" "") Just packages -> case eitherDecode $ BS.fromStrict $ encodeUtf8 packages of - Left e -> sendResponseStatus status400 ("could not parse query param \"ids\"" <> show e :: Text) + Left _ -> sendResponseStatus status400 (InvalidParamsE "get:ids" packages) Right (p :: [PkgId]) -> do let packageList :: [(PkgId, Maybe Version)] = (, Nothing) <$> p found <- runDB $ traverse fetchLatestApp $ fst <$> packageList @@ -404,9 +432,8 @@ getPackageListR = do let satisfactory = filter (<|| spec) (fst pacakgeMetadata) let best = getMax <$> foldMap (Just . Max) satisfactory case best of - Nothing -> - pure $ Left $ "best version could not be found for " <> show appId <> " with spec " <> show spec - Just v -> do + Nothing -> pure $ Left $ [i|Best version could not be found for #{appId} with spec #{spec}|] + Just v -> do pure $ Right (Just v, appId) getServiceDetails :: (MonadIO m, MonadResource m) @@ -424,7 +451,7 @@ getServiceDetails settings metadata maybeVersion pkg = runExceptT $ do Nothing -> do -- grab first value, which will be the latest version case fst packageMetadata of - [] -> liftEither . Left $ NotFoundE $ "no latest version found for " <> show pkg + [] -> liftEither . Left $ NotFoundE $ [i|No latest version found for #{pkg}|] x : _ -> pure x Just v -> pure v manifest <- flip runReaderT settings $ (snd <$> getManifest pkg version) >>= \bs -> @@ -455,7 +482,7 @@ mapDependencyMetadata domain metadata (appId, depInfo) = do let satisfactory = filter (<|| serviceDependencyInfoVersion depInfo) (fst depMetadata) let best = getMax <$> foldMap (Just . Max) satisfactory version <- case best of - Nothing -> Left $ NotFoundE $ "best version not found for dependent package " <> show appId + Nothing -> Left $ NotFoundE $ [i|No satisfactory version for dependent package #{appId}|] Just v -> pure v pure ( appId diff --git a/src/Handler/Version.hs b/src/Handler/Version.hs index 4e0a1ac..6839bbf 100644 --- a/src/Handler/Version.hs +++ b/src/Handler/Version.hs @@ -11,25 +11,15 @@ import Startlude hiding ( Handler ) import Yesod.Core -import qualified Data.Attoparsec.Text as Atto import Data.String.Interpolate.IsString ( i ) -import qualified Data.Text as T -import qualified Data.Text.IO as T import Foundation import Handler.Types.Status import Lib.Error ( S9Error(NotFoundE) ) import Lib.PkgRepository ( getBestVersion ) import Lib.Types.AppIndex ( PkgId ) -import Lib.Types.Emver ( Version(..) - , parseVersion - , satisfies - ) import Network.HTTP.Types.Status ( status404 ) import Settings -import System.FilePath ( () ) -import System.IO.Error ( isDoesNotExistError ) -import UnliftIO.Directory ( listDirectory ) import Util.Shared ( getVersionSpecFromQuery , orThrow ) @@ -43,25 +33,3 @@ getPkgVersionR pkg = do AppVersionRes <$> getBestVersion pkg spec `orThrow` sendResponseStatus status404 (NotFoundE [i|Version for #{pkg} satisfying #{spec}|]) - - -data EosVersionRes = EosVersionRes - { eosVersionVersion :: Version - , eosVersionReleaseNotes :: Text - } - -getEosVersionR :: Handler EosVersionRes -getEosVersionR = do - spec <- getVersionSpecFromQuery - root <- getsYesod $ ( "eos") . resourcesDir . appSettings - subdirs <- listDirectory root - let (failures, successes) = partitionEithers $ (Atto.parseOnly parseVersion . T.pack) <$> subdirs - for_ failures $ \f -> $logWarn [i|Emver Parse Failure for EOS: #{f}|] - let res = headMay . sortOn Down . filter (`satisfies` spec) $ successes - case res of - Nothing -> sendResponseStatus status404 (NotFoundE [i|EOS version satisfying #{spec}|]) - Just r -> do - let notesPath = root show r "release-notes.md" - notes <- liftIO $ T.readFile notesPath `catch` \e -> - if isDoesNotExistError e then pure [i|# Release Notes Missing for #{r}|] else throwIO e - pure $ EosVersionRes r notes diff --git a/src/Lib/PkgRepository.hs b/src/Lib/PkgRepository.hs index d0ede79..f79d4d6 100644 --- a/src/Lib/PkgRepository.hs +++ b/src/Lib/PkgRepository.hs @@ -48,7 +48,6 @@ import Startlude ( ($) , (&&) , (.) , (<$>) - , (<>) , Bool(..) , ByteString , Down(..) @@ -234,7 +233,7 @@ getIcon pkg version = do let pkgRoot = root show pkg show version mIconFile <- find ((== "icon") . takeBaseName) <$> listDirectory pkgRoot case mIconFile of - Nothing -> throwIO $ NotFoundE $ show pkg <> ": Icon" + Nothing -> throwIO $ NotFoundE $ [i|#{pkg}: Icon|] Just x -> do let ct = case takeExtension x of ".png" -> typePng diff --git a/src/Lib/Types/AppIndex.hs b/src/Lib/Types/AppIndex.hs index a6d23d4..40fad6f 100644 --- a/src/Lib/Types/AppIndex.hs +++ b/src/Lib/Types/AppIndex.hs @@ -49,7 +49,7 @@ instance ToJSONKey PkgId where instance PersistField PkgId where toPersistValue = PersistText . show fromPersistValue (PersistText t) = Right . PkgId $ toS t - fromPersistValue other = Left $ "Invalid AppId: " <> show other + fromPersistValue other = Left $ [i|Invalid AppId: #{other}|] instance PersistFieldSql PkgId where sqlType _ = SqlString instance PathPiece PkgId where