Files
registry/src/Handler/Marketplace.hs
Keagan McClelland 46c079fe25 delete unused code
2022-02-26 23:27:27 -07:00

509 lines
22 KiB
Haskell

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DeriveAnyClass #-}
module Handler.Marketplace where
import 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 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.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
type URL = Text
newtype CategoryRes = CategoryRes {
categories :: [CategoryTitle]
} deriving (Show, Generic)
instance ToJSON CategoryRes
instance FromJSON CategoryRes
instance ToContent CategoryRes where
toContent = toContent . toJSON
instance ToTypedContent CategoryRes where
toTypedContent = toTypedContent . toJSON
data ServiceRes = ServiceRes
{ serviceResIcon :: URL
, serviceResManifest :: Data.Aeson.Value -- ServiceManifest
, serviceResCategories :: [CategoryTitle]
, serviceResInstructions :: URL
, serviceResLicense :: URL
, serviceResVersions :: [Version]
, serviceResDependencyInfo :: HM.HashMap PkgId DependencyInfo
}
deriving Generic
newtype ReleaseNotes = ReleaseNotes { unReleaseNotes :: HM.HashMap Version Text }
deriving (Eq, Show)
instance ToJSON ReleaseNotes where
toJSON ReleaseNotes {..} = object [ t .= v | (k, v) <- HM.toList unReleaseNotes, let (String t) = toJSON k ]
instance ToContent ReleaseNotes where
toContent = toContent . toJSON
instance ToTypedContent ReleaseNotes where
toTypedContent = toTypedContent . toJSON
instance ToJSON ServiceRes where
toJSON ServiceRes {..} = object
[ "icon" .= serviceResIcon
, "license" .= serviceResLicense
, "instructions" .= serviceResInstructions
, "manifest" .= serviceResManifest
, "categories" .= serviceResCategories
, "versions" .= serviceResVersions
, "dependency-metadata" .= serviceResDependencyInfo
]
instance ToContent ServiceRes where
toContent = toContent . toJSON
instance ToTypedContent ServiceRes where
toTypedContent = toTypedContent . toJSON
data DependencyInfo = DependencyInfo
{ dependencyInfoTitle :: PkgId
, dependencyInfoIcon :: URL
}
deriving (Eq, Show)
instance ToJSON DependencyInfo where
toJSON DependencyInfo {..} = object ["icon" .= dependencyInfoIcon, "title" .= dependencyInfoTitle]
data ServiceListRes = ServiceListRes
{ serviceListResCategories :: [CategoryTitle]
, serviceListResServices :: [ServiceAvailable]
}
deriving Show
instance ToJSON ServiceListRes where
toJSON ServiceListRes {..} =
object ["categories" .= serviceListResCategories, "services" .= serviceListResServices]
instance ToContent ServiceListRes where
toContent = toContent . toJSON
instance ToTypedContent ServiceListRes where
toTypedContent = toTypedContent . toJSON
data ServiceAvailable = ServiceAvailable
{ serviceAvailableId :: PkgId
, serviceAvailableTitle :: Text
, serviceAvailableVersion :: Version
, serviceAvailableIcon :: URL
, serviceAvailableDescShort :: Text
}
deriving Show
instance ToJSON ServiceAvailable where
toJSON ServiceAvailable {..} = object
[ "id" .= serviceAvailableId
, "title" .= serviceAvailableTitle
, "version" .= serviceAvailableVersion
, "icon" .= serviceAvailableIcon
, "descriptionShort" .= serviceAvailableDescShort
]
instance ToContent ServiceAvailable where
toContent = toContent . toJSON
instance ToTypedContent ServiceAvailable where
toTypedContent = toTypedContent . toJSON
newtype ServiceAvailableRes = ServiceAvailableRes [ServiceRes]
deriving (Generic)
instance ToJSON ServiceAvailableRes
instance ToContent ServiceAvailableRes where
toContent = toContent . toJSON
instance ToTypedContent ServiceAvailableRes where
toTypedContent = toTypedContent . toJSON
newtype VersionLatestRes = VersionLatestRes (HM.HashMap PkgId (Maybe Version))
deriving (Show, Generic)
instance ToJSON VersionLatestRes
instance ToContent VersionLatestRes where
toContent = toContent . toJSON
instance ToTypedContent VersionLatestRes where
toTypedContent = toTypedContent . toJSON
data OrderArrangement = ASC | DESC
deriving (Eq, Show, Read)
data ServiceListDefaults = ServiceListDefaults
{ serviceListOrder :: OrderArrangement
, serviceListPageLimit :: Int64 -- the number of items per page
, serviceListPageNumber :: Int64 -- the page you are on
, serviceListCategory :: Maybe CategoryTitle
, serviceListQuery :: Text
}
deriving (Eq, Show, Read)
data EosRes = EosRes
{ eosResVersion :: Version
, eosResHeadline :: Text
, eosResReleaseNotes :: ReleaseNotes
}
deriving (Eq, Show, Generic)
instance ToJSON EosRes where
toJSON EosRes {..} =
object ["version" .= eosResVersion, "headline" .= eosResHeadline, "release-notes" .= eosResReleaseNotes]
instance ToContent EosRes where
toContent = toContent . toJSON
instance ToTypedContent EosRes where
toTypedContent = toTypedContent . toJSON
data PackageVersion = PackageVersion
{ packageVersionId :: PkgId
, packageVersionVersion :: VersionRange
}
deriving Show
instance FromJSON PackageVersion where
parseJSON = withObject "package version" $ \o -> do
packageVersionId <- o .: "id"
packageVersionVersion <- o .: "version"
pure PackageVersion { .. }
getCategoriesR :: Handler CategoryRes
getCategoriesR = do
allCategories <- runDB $ select $ do
cats <- from $ table @Category
orderBy [desc (cats ^. CategoryPriority)]
pure cats
pure $ CategoryRes $ categoryName . entityVal <$> allCategories
getEosR :: Handler EosRes
getEosR = do
allEosVersions <- runDB $ select $ do
vers <- from $ table @OsVersion
orderBy [desc (vers ^. OsVersionCreatedAt)]
pure vers
let osV = entityVal <$> allEosVersions
let latest = Data.List.head osV
let mappedVersions =
ReleaseNotes
$ HM.fromList
$ sortOn (Down . fst)
$ (\v -> (osVersionNumber v, osVersionReleaseNotes v))
<$> osV
pure $ EosRes { eosResVersion = osVersionNumber latest
, eosResHeadline = osVersionHeadline latest
, eosResReleaseNotes = mappedVersions
}
getReleaseNotesR :: Handler ReleaseNotes
getReleaseNotesR = do
getParameters <- reqGetParams <$> getRequest
case lookup "id" getParameters of
Nothing -> sendResponseStatus status400 ("expected query param \"id\" to exist" :: Text)
Just package -> do
(service, _) <- runDB $ fetchLatestApp (PkgId package) >>= errOnNothing status404 "package not found"
(_, mappedVersions) <- fetchAllAppVersions (entityKey service)
pure mappedVersions
getVersionLatestR :: Handler VersionLatestRes
getVersionLatestR = do
getParameters <- reqGetParams <$> getRequest
case lookup "ids" getParameters of
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 :: [PkgId]) -> do
let packageList :: [(PkgId, 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
getPackageListR :: Handler ServiceAvailableRes
getPackageListR = do
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 = ""
}
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)
getServiceDetails :: (MonadUnliftIO m, Monad m, MonadResource m)
=> AppSettings
-> (HM.HashMap PkgId ([Version], [CategoryTitle]))
-> Maybe Version
-> PkgId
-> m (Either Text ServiceRes)
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 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
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
-> 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.|]
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
Just v -> pure v
pure $ Right
( appId
, DependencyInfo { dependencyInfoTitle = appId
, dependencyInfoIcon = [i|https://#{domain}/package/icon/#{appId}?spec==#{version}|]
}
)
fetchAllAppVersions :: Key SApp -> HandlerFor RegistryCtx ([VersionInfo], ReleaseNotes)
fetchAllAppVersions appId = do
entityAppVersions <- runDB $ P.selectList [SVersionAppId P.==. appId] [] -- orderby version
let vers = entityVal <$> entityAppVersions
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
version <- from $ table @SVersion
where_ (version ^. SVersionAppId ==. val appId)
orderBy [desc (version ^. SVersionNumber)]
limit 1
pure version
fetchLatestApp :: MonadIO m => PkgId -> ReaderT SqlBackend m (Maybe (P.Entity SApp, P.Entity SVersion))
fetchLatestApp appId = selectOne $ do
(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
=> PkgId
-> Version
-> ReaderT SqlBackend m (Maybe (P.Entity SApp, P.Entity SVersion))
fetchLatestAppAtVersion appId version' = selectOne $ do
(service :& version) <-
from
$ table @SApp
`innerJoin` table @SVersion
`on` (\(service :& version) -> service ^. SAppId ==. version ^. SVersionAppId)
where_ $ (service ^. SAppAppId ==. val appId) &&. (version ^. SVersionNumber ==. val version')
pure (service, version)
fetchPackageMetadata :: (MonadLogger m, MonadUnliftIO m)
=> ReaderT SqlBackend m (HM.HashMap PkgId ([Version], [CategoryTitle]))
fetchPackageMetadata = do
let categoriesQuery = select $ do
(service :& category) <-
from
$ table @SApp
`leftJoin` table @ServiceCategory
`on` (\(service :& category) ->
Database.Esqueleto.Experimental.just (service ^. SAppId)
==. category
?. ServiceCategoryServiceId
)
Database.Esqueleto.Experimental.groupBy $ service ^. SAppAppId
pure (service ^. SAppAppId, arrayAggDistinct (category ?. ServiceCategoryCategoryName))
let versionsQuery = select $ do
(service :& version) <-
from
$ table @SApp
`innerJoin` table @SVersion
`on` (\(service :& version) -> (service ^. SAppId) ==. version ^. SVersionAppId)
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'))
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
(categories :& service) <-
from
$ table @ServiceCategory
`innerJoin` table @SApp
`on` (\(sc :& s) -> sc ^. ServiceCategoryServiceId ==. s ^. SAppId)
where_ (service ^. SAppId ==. val appId)
pure categories
-- >>> encode hm
-- "{\"0.2.0\":\"some notes\"}"
hm :: Data.Aeson.Value
hm = object [ t .= v | (k, v) <- [("0.2.0", "some notes") :: (Version, Text)], let (String t) = toJSON k ]
-- >>> encode rn
-- "{\"0.2.0\":\"notes one\",\"0.3.0\":\"notes two\"}"
rn :: ReleaseNotes
rn = ReleaseNotes $ HM.fromList [("0.2.0", "notes one"), ("0.3.0", "notes two")]
-- >>> readMaybe $ cc :: Maybe CategoryTitle
-- Just FEATURED
cc :: Text
cc = T.toUpper "featured"
-- >>> encode ccc
-- "\"featured\""
ccc :: CategoryTitle
ccc = FEATURED