Start9/registry
2
0
Fork 0
mirror of https://github.com/Start9Labs/registry.git synced 2026-03-26 02:11:53 +00:00
Code Issues Packages Projects Releases Wiki Activity

reduce io dependence

Browse Source
This commit is contained in:
Keagan McClelland
2021-09-29 14:00:49 -06:00
parent 468b65f43c
commit 99dea51f7d
4 changed files with 135 additions and 60 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1
package.yaml
View File

@@ -37,6 +37,7 @@ dependencies:
- lens - lens
- monad-logger - monad-logger
- monad-logger-extras - monad-logger-extras
- parallel
- persistent - persistent
- persistent-postgresql - persistent-postgresql
- persistent-template - persistent-template

4
src/Handler/Apps.hs
View File

@@ -19,7 +19,6 @@ import Data.Aeson ( ToJSON
) )
import qualified Data.Attoparsec.Text as Atto import qualified Data.Attoparsec.Text as Atto
import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy as BS
import qualified Data.Conduit.Binary as CB
import qualified Data.Text as T import qualified Data.Text as T
import Database.Persist ( Entity(entityKey) ) import Database.Persist ( Entity(entityKey) )
import qualified GHC.Show ( Show(..) ) import qualified GHC.Show ( Show(..) )
@@ -27,9 +26,6 @@ import Network.HTTP.Types ( status404 )
import System.FilePath ( (<.>) import System.FilePath ( (<.>)
, takeBaseName , takeBaseName
) )
import System.Posix.Files ( fileSize
, getFileStatus
)
import Yesod.Core ( TypedContent import Yesod.Core ( TypedContent
, addHeader , addHeader
, notFound , notFound

177
src/Handler/Marketplace.hs
View File

@@ -11,40 +11,117 @@
{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveAnyClass #-}
module Handler.Marketplace where 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 import Startlude hiding ( Handler
, from , from
, on , on
, sortOn , sortOn
) )
import UnliftIO.Async
import Yesod.Core import Conduit ( (.|)
import Yesod.Persist.Core , 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 type URL = Text
newtype CategoryRes = CategoryRes { newtype CategoryRes = CategoryRes {
@@ -332,57 +409,55 @@ getPackageListR = do
Just v -> do Just v -> do
pure $ Right (Just v, appId) pure $ Right (Just v, appId)
getServiceDetails :: (MonadUnliftIO m, Monad m, MonadResource m) getServiceDetails :: (MonadIO m, MonadResource m)
=> AppSettings => AppSettings
-> (HM.HashMap PkgId ([Version], [CategoryTitle])) -> (HM.HashMap PkgId ([Version], [CategoryTitle]))
-> Maybe Version -> Maybe Version
-> PkgId -> PkgId
-> m (Either Text ServiceRes) -> m (Either S9Error ServiceRes)
getServiceDetails settings metadata maybeVersion pkg = do getServiceDetails settings metadata maybeVersion pkg = runExceptT $ do
packageMetadata <- case HM.lookup pkg metadata of 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 Just m -> pure m
let domain = registryHostname settings let domain = registryHostname settings
version <- case maybeVersion of version <- case maybeVersion of
Nothing -> do Nothing -> do
-- grab first value, which will be the latest version -- grab first value, which will be the latest version
case fst packageMetadata of 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 x : _ -> pure x
Just v -> pure v Just v -> pure v
manifest <- flip runReaderT settings $ (snd <$> getManifest pkg version) >>= \bs -> manifest <- flip runReaderT settings $ (snd <$> getManifest pkg version) >>= \bs ->
runConduit $ bs .| CL.foldMap BS.fromStrict runConduit $ bs .| CL.foldMap BS.fromStrict
case eitherDecode manifest of 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 Right m -> do
d <- liftIO $ mapConcurrently (mapDependencyMetadata domain metadata) let d = parMap rpar (mapDependencyMetadata domain metadata) (HM.toList $ serviceManifestDependencies m)
(HM.toList $ serviceManifestDependencies m) pure $ ServiceRes { serviceResIcon = [i|https://#{domain}/package/icon/#{pkg}|]
pure $ Right $ ServiceRes { serviceResIcon = [i|https://#{domain}/package/icon/#{pkg}|]
-- pass through raw JSON Value, we have checked its correct parsing above -- pass through raw JSON Value, we have checked its correct parsing above
, serviceResManifest = unsafeFromJust . decode $ manifest , serviceResManifest = unsafeFromJust . decode $ manifest
, serviceResCategories = snd packageMetadata , serviceResCategories = snd packageMetadata
, serviceResInstructions = [i|https://#{domain}/package/instructions/#{pkg}|] , serviceResInstructions = [i|https://#{domain}/package/instructions/#{pkg}|]
, serviceResLicense = [i|https://#{domain}/package/license/#{pkg}|] , serviceResLicense = [i|https://#{domain}/package/license/#{pkg}|]
, serviceResVersions = fst packageMetadata , serviceResVersions = fst packageMetadata
, serviceResDependencyInfo = HM.fromList $ snd $ partitionEithers d , serviceResDependencyInfo = HM.fromList $ snd $ partitionEithers d
} }
mapDependencyMetadata :: (MonadIO m) mapDependencyMetadata :: Text
=> Text
-> HM.HashMap PkgId ([Version], [CategoryTitle]) -> HM.HashMap PkgId ([Version], [CategoryTitle])
-> (PkgId, ServiceDependencyInfo) -> (PkgId, ServiceDependencyInfo)
-> m (Either Text (PkgId, DependencyInfo)) -> Either S9Error (PkgId, DependencyInfo)
mapDependencyMetadata domain metadata (appId, depInfo) = do mapDependencyMetadata domain metadata (appId, depInfo) = do
depMetadata <- case HM.lookup appId metadata of 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 Just m -> pure m
-- get best version from VersionRange of dependency -- get best version from VersionRange of dependency
let satisfactory = filter (<|| serviceDependencyInfoVersion depInfo) (fst depMetadata) let satisfactory = filter (<|| serviceDependencyInfoVersion depInfo) (fst depMetadata)
let best = getMax <$> foldMap (Just . Max) satisfactory let best = getMax <$> foldMap (Just . Max) satisfactory
version <- case best of 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 Just v -> pure v
pure $ Right pure
( appId ( appId
, DependencyInfo { dependencyInfoTitle = appId , DependencyInfo { dependencyInfoTitle = appId
, dependencyInfoIcon = [i|https://#{domain}/package/icon/#{appId}?spec==#{version}|] , dependencyInfoIcon = [i|https://#{domain}/package/icon/#{appId}?spec==#{version}|]

13
src/Lib/Error.hs
View File

@@ -16,6 +16,7 @@ data S9Error =
| AppMgrE Text ExitCode | AppMgrE Text ExitCode
| NotFoundE Text | NotFoundE Text
| InvalidParamsE Text Text | InvalidParamsE Text Text
| AssetParseE Text Text
deriving (Show, Eq) deriving (Show, Eq)
instance Exception S9Error instance Exception S9Error
@@ -23,17 +24,18 @@ instance Exception S9Error
-- | Redact any sensitive data in this function -- | Redact any sensitive data in this function
toError :: S9Error -> Error toError :: S9Error -> Error
toError = \case toError = \case
PersistentE t -> Error DATABASE_ERROR t PersistentE t -> Error DATABASE_ERROR t
AppMgrE cmd code -> Error APPMGR_ERROR [i|"appmgr #{cmd}" exited with #{code}|] AppMgrE cmd code -> Error APPMGR_ERROR [i|"appmgr #{cmd}" exited with #{code}|]
NotFoundE e -> Error NOT_FOUND [i|#{e}|] NotFoundE e -> Error NOT_FOUND [i|#{e}|]
InvalidParamsE e m -> Error INVALID_PARAMS [i|Could not parse request parameters #{e}: #{m}|] 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 = data ErrorCode =
DATABASE_ERROR DATABASE_ERROR
| APPMGR_ERROR | APPMGR_ERROR
| NOT_FOUND | NOT_FOUND
| INVALID_PARAMS | INVALID_PARAMS
| PARSE_ERROR
deriving (Eq, Show) deriving (Eq, Show)
instance ToJSON ErrorCode where instance ToJSON ErrorCode where
toJSON = String . show toJSON = String . show
@@ -61,6 +63,7 @@ toStatus = \case
AppMgrE _ _ -> status500 AppMgrE _ _ -> status500
NotFoundE _ -> status404 NotFoundE _ -> status404
InvalidParamsE _ _ -> status400 InvalidParamsE _ _ -> status400
AssetParseE _ _ -> status500
handleS9ErrT :: MonadHandler m => S9ErrT m a -> m a handleS9ErrT :: MonadHandler m => S9ErrT m a -> m a