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