limit strict bs converstion and refactor to not use fs read

.gitignore

@@ -31,3 +31,4 @@ version
 **/appmgr
 0.3.0_features.md
 **/embassy-sdk
+start9-registry.prof

resources/apps/apps.yaml

@@ -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: '*'

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"

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)
@@ -284,10 +286,13 @@ getPackageListR = do
             Right (packages :: [PackageVersion]) -> do
                 -- for each item in list get best available from version range
                 settings                <- getsYesod appSettings
-                availableServices   <- traverse (getPackageDetails settings) packages
+                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))

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

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

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