mirror of
https://github.com/Start9Labs/registry.git
synced 2026-03-30 03:41:57 +00:00
400 lines
18 KiB
Haskell
400 lines
18 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE TypeApplications #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE DeriveGeneric #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
|
|
|
|
module Handler.Marketplace where
|
|
import Startlude hiding (from, Handler, on)
|
|
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
|
|
|
|
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 :: Text
|
|
, serviceResManifest :: ServiceManifest
|
|
, serviceResCategories :: [CategoryTitle]
|
|
, serviceResInstructions :: Text -- markdown
|
|
, serviceResLicense :: Text
|
|
, serviceResVersions :: [Version]
|
|
, serviceResDependencyInfo :: HM.HashMap AppIdentifier DependencyInfo
|
|
, serviceResReleaseNotes :: ReleaseNotes
|
|
} deriving (Show, 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 ToJSON ServiceRes where
|
|
toJSON ServiceRes {..} = object
|
|
[ "icon" .= serviceResIcon
|
|
, "manifest" .= serviceResManifest
|
|
, "categories" .= serviceResCategories
|
|
, "instructions" .= serviceResInstructions
|
|
, "license" .= serviceResLicense
|
|
, "versions" .= serviceResVersions
|
|
, "dependency-metadata" .= serviceResDependencyInfo
|
|
, "release-notes" .= serviceResReleaseNotes
|
|
]
|
|
instance ToContent ServiceRes where
|
|
toContent = toContent . toJSON
|
|
instance ToTypedContent ServiceRes where
|
|
toTypedContent = toTypedContent . toJSON
|
|
data DependencyInfo = DependencyInfo
|
|
{ dependencyInfoTitle :: Text -- title
|
|
, dependencyInfoIcon :: Text -- 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 :: Text
|
|
, 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 [ServiceAvailable]
|
|
deriving (Show, Generic)
|
|
instance ToJSON ServiceAvailableRes
|
|
instance ToContent ServiceAvailableRes where
|
|
toContent = toContent . toJSON
|
|
instance ToTypedContent ServiceAvailableRes 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 :: CategoryTitle
|
|
, serviceListQuery :: Text
|
|
}
|
|
deriving (Eq, Show, Read)
|
|
|
|
data EosRes = EosRes
|
|
{ eosResVersion :: Version
|
|
, eosResHeadline :: Text
|
|
, eosResReleaseNotes :: ReleaseNotes
|
|
} deriving (Eq, Show, Generic)
|
|
instance ToJSON EosRes
|
|
instance ToContent EosRes where
|
|
toContent = toContent . toJSON
|
|
instance ToTypedContent EosRes where
|
|
toTypedContent = toTypedContent . toJSON
|
|
|
|
getCategoriesR :: Handler CategoryRes
|
|
getCategoriesR = do
|
|
allCategories <- runDB $ select $ do from $ table @Category
|
|
pure $ CategoryRes $ categoryName . entityVal <$>allCategories
|
|
|
|
getEosR :: Handler EosRes
|
|
getEosR = do
|
|
allEosVersions <- runDB $ select $ do
|
|
vers <- from $ table @OsVersion
|
|
orderBy [desc (vers ^. OsVersionUpdatedAt)]
|
|
pure vers
|
|
let osV = entityVal <$> allEosVersions
|
|
let latest = Data.List.head osV
|
|
let mappedVersions = ReleaseNotes $ HM.fromList $ (\v -> (osVersionNumber v, osVersionReleaseNotes v)) <$> osV
|
|
pure $ EosRes
|
|
{ eosResVersion = osVersionNumber latest
|
|
, eosResHeadline = osVersionHeadline latest
|
|
, eosResReleaseNotes = mappedVersions
|
|
}
|
|
|
|
getServiceListR :: Handler ServiceAvailableRes
|
|
getServiceListR = do
|
|
getParameters <- reqGetParams <$> getRequest
|
|
let defaults = ServiceListDefaults {
|
|
serviceListOrder = DESC
|
|
, serviceListPageLimit = 20
|
|
, serviceListPageNumber = 1
|
|
, serviceListCategory = ANY
|
|
, serviceListQuery = ""
|
|
}
|
|
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 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"
|
|
$logInfo $ show category
|
|
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
|
|
pure $ ServiceAvailableRes res
|
|
|
|
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")
|
|
(versions, mappedVersions) <- fetchAllAppVersions (entityKey service)
|
|
categories <- runDB $ fetchAppCategories (entityKey service)
|
|
(appsDir, appMgrDir) <- getsYesod $ ((</> "apps") . resourcesDir &&& staticBinDir) . appSettings
|
|
domain <- getsYesod $ registryHostname . appSettings
|
|
let appId = sAppAppId $ entityVal service
|
|
let appDir = (<> "/") . (</> show (sVersionNumber $ entityVal 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 :: ServiceManifest) -> pure a
|
|
d <- traverse (mapDependencyMetadata appsDir appMgrDir domain) (HM.toList $ serviceManifestDependencies manifest)
|
|
let depPath = appsDir </> toS appId </> show version
|
|
-- @TODO uncomment when sdk icon working
|
|
-- icon <- decodeIcon appMgrDir depPath appExt
|
|
let icon = [i|https://#{domain}/icons/#{appId}.png|]
|
|
instructions <- decodeInstructions appMgrDir depPath appExt
|
|
license <- decodeLicense appMgrDir depPath appExt
|
|
addPackageHeader appMgrDir appDir appExt
|
|
pure $ ServiceRes
|
|
{ serviceResIcon = icon
|
|
, serviceResManifest = manifest -- TypedContent "application/json" (toContent manifest)
|
|
, serviceResCategories = serviceCategoryCategoryName . entityVal <$> categories
|
|
, serviceResInstructions = instructions
|
|
, serviceResLicense = license
|
|
, serviceResVersions = versionInfoVersion <$> versions
|
|
, serviceResDependencyInfo = HM.fromList d
|
|
, serviceResReleaseNotes = mappedVersions
|
|
}
|
|
|
|
type URL = Text
|
|
mapDependencyMetadata :: (MonadIO m, MonadHandler m) => FilePath -> FilePath -> Text -> (AppIdentifier, ServiceDependencyInfo) -> m (AppIdentifier, DependencyInfo)
|
|
mapDependencyMetadata appsDir appmgrPath domain (appId, depInfo) = do
|
|
let ext = (Extension (toS appId) :: Extension "s9pk")
|
|
-- get best version from VersionRange of dependency
|
|
version <- getBestVersion appsDir ext (serviceDependencyInfoVersion depInfo) >>= \case
|
|
Nothing -> sendResponseStatus status400 ("Specified App Version Not Found" :: Text)
|
|
Just v -> pure v
|
|
let depPath = appsDir </> toS appId </> show version
|
|
-- @TODO uncomment when sdk icon working
|
|
-- icon <- decodeIcon appmgrPath depPath ext
|
|
let icon = [i|https://#{domain}/icons/#{appId}.png|]
|
|
pure (appId, DependencyInfo
|
|
{ dependencyInfoTitle = appId
|
|
, dependencyInfoIcon = 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 $ BS.fromStrict 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 appmgrPath depPath package = do
|
|
instructions <- handleS9ErrT $ getInstructions appmgrPath depPath package
|
|
case eitherDecode $ BS.fromStrict instructions of
|
|
Left e -> do
|
|
$logInfo $ T.pack e
|
|
sendResponseStatus status400 e
|
|
Right a -> pure a
|
|
|
|
decodeLicense :: (MonadHandler m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> m Text
|
|
decodeLicense appmgrPath depPath package = do
|
|
license <- handleS9ErrT $ getLicense appmgrPath depPath package
|
|
case eitherDecode $ BS.fromStrict license of
|
|
Left e -> do
|
|
$logInfo $ T.pack e
|
|
sendResponseStatus status400 e
|
|
Right a -> pure a
|
|
|
|
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)
|
|
|
|
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 => Text -> 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 => Text -> 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)
|
|
|
|
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
|
|
|
|
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
|
|
}
|
|
|
|
mapEntityToServiceAvailable :: (MonadIO m, MonadHandler m) => FilePath -> FilePath -> Text -> Entity SApp -> ReaderT SqlBackend m ServiceAvailable
|
|
mapEntityToServiceAvailable appMgrDir appsDir domain service = do
|
|
-- @TODO uncomment and replace icon when portable embassy-sdk live
|
|
-- icon <- decodeIcon appMgrDir appsDir (Extension "png")
|
|
let appId = sAppAppId $ entityVal service
|
|
let icon = [i|https://#{domain}/icons/#{appId}.png|]
|
|
(_, 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 = icon
|
|
}
|
|
|
|
-- >>> 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
|
|
|