mirror of
https://github.com/Start9Labs/registry.git
synced 2026-03-26 10:21:51 +00:00
builds
This commit is contained in:
Keagan McClelland
@@ -11,36 +11,64 @@ module Handler.Apps where
|
||||
|
||||
import Startlude hiding ( Handler )
|
||||
|
||||
import Control.Monad.Logger
|
||||
import Data.Aeson
|
||||
import Control.Monad.Logger ( logError
|
||||
, logInfo
|
||||
)
|
||||
import Data.Aeson ( ToJSON
|
||||
, encode
|
||||
)
|
||||
import qualified Data.Attoparsec.Text as Atto
|
||||
import qualified Data.ByteString.Lazy as BS
|
||||
import Data.Conduit
|
||||
import qualified Data.Conduit.Binary as CB
|
||||
import qualified Data.Text as T
|
||||
import Database.Persist
|
||||
import Database.Persist ( Entity(entityKey) )
|
||||
import qualified GHC.Show ( Show(..) )
|
||||
import Network.HTTP.Types
|
||||
import System.Directory
|
||||
import Network.HTTP.Types ( status404 )
|
||||
import System.FilePath ( (<.>)
|
||||
, (</>)
|
||||
, takeBaseName
|
||||
)
|
||||
import System.Posix.Files ( fileSize
|
||||
, getFileStatus
|
||||
)
|
||||
import Yesod.Core
|
||||
import Yesod.Persist.Core
|
||||
import Yesod.Core ( MonadHandler(HandlerSite)
|
||||
, TypedContent
|
||||
, addHeader
|
||||
, getYesod
|
||||
, notFound
|
||||
, respondSource
|
||||
, sendChunkBS
|
||||
, sendResponseStatus
|
||||
, typeJson
|
||||
, typeOctet
|
||||
, waiRequest
|
||||
)
|
||||
import Yesod.Persist.Core ( YesodPersist(runDB) )
|
||||
|
||||
import Database.Queries
|
||||
import Foundation
|
||||
import Lib.External.AppMgr
|
||||
import Lib.Registry
|
||||
import Lib.Types.AppIndex
|
||||
import Lib.Types.Emver
|
||||
import Lib.Types.FileSystem
|
||||
import Conduit ( (.|)
|
||||
, awaitForever
|
||||
)
|
||||
import Data.String.Interpolate.IsString
|
||||
( i )
|
||||
import Database.Queries ( createMetric
|
||||
, fetchApp
|
||||
, fetchAppVersion
|
||||
)
|
||||
import Foundation ( Handler )
|
||||
import Lib.Error ( S9Error(NotFoundE) )
|
||||
import Lib.PkgRepository ( getBestVersion
|
||||
, getManifest
|
||||
, getPackage
|
||||
)
|
||||
import Lib.Registry ( S9PK )
|
||||
import Lib.Types.AppIndex ( PkgId(PkgId) )
|
||||
import Lib.Types.Emver ( Version
|
||||
, parseVersion
|
||||
)
|
||||
import Network.Wai ( Request(requestHeaderUserAgent) )
|
||||
import Settings
|
||||
import Util.Shared
|
||||
import Util.Shared ( addPackageHeader
|
||||
, getVersionSpecFromQuery
|
||||
, orThrow
|
||||
)
|
||||
|
||||
pureLog :: Show a => a -> Handler a
|
||||
pureLog = liftA2 (*>) ($logInfo . show) pure
|
||||
@@ -48,6 +76,11 @@ pureLog = liftA2 (*>) ($logInfo . show) pure
|
||||
logRet :: ToJSON a => Handler a -> Handler a
|
||||
logRet = (>>= liftA2 (*>) ($logInfo . decodeUtf8 . BS.toStrict . encode) pure)
|
||||
|
||||
inject :: MonadHandler m => ReaderT (HandlerSite m) m a -> m a
|
||||
inject action = do
|
||||
env <- getYesod
|
||||
runReaderT action env
|
||||
|
||||
data FileExtension = FileExtension FilePath (Maybe String)
|
||||
instance Show FileExtension where
|
||||
show (FileExtension f Nothing ) = f
|
||||
@@ -64,76 +97,40 @@ getEmbassyOsVersion = userAgentOsVersion
|
||||
userAgentOsVersion =
|
||||
(hush . Atto.parseOnly userAgentOsVersionParser . decodeUtf8 <=< requestHeaderUserAgent) <$> waiRequest
|
||||
|
||||
getSysR :: Extension "" -> Handler TypedContent
|
||||
getSysR e = do
|
||||
sysResourceDir <- (</> "sys") . resourcesDir . appSettings <$> getYesod
|
||||
-- @TODO update with new response type here
|
||||
getApp sysResourceDir e
|
||||
|
||||
getAppManifestR :: PkgId -> Handler TypedContent
|
||||
getAppManifestR appId = do
|
||||
-- (appsDir, appMgrDir) <- getsYesod $ ((</> "apps") . resourcesDir &&& staticBinDir) . appSettings
|
||||
-- av <- getVersionFromQuery appsDir appExt >>= \case
|
||||
-- Nothing -> sendResponseStatus status404 ("Specified App Version Not Found" :: Text)
|
||||
-- Just v -> pure v
|
||||
-- let appDir = (<> "/") . (</> show av) . (</> show appId) $ appsDir
|
||||
-- addPackageHeader appMgrDir appDir appExt
|
||||
-- sourceManifest appMgrDir
|
||||
-- appDir
|
||||
-- appExt
|
||||
-- (\bsSource -> respondSource "application/json" (bsSource .| awaitForever sendChunkBS))
|
||||
-- where appExt = Extension (show appId) :: Extension "s9pk"
|
||||
_
|
||||
getAppManifestR pkg = do
|
||||
versionSpec <- getVersionSpecFromQuery
|
||||
version <- getBestVersion pkg versionSpec
|
||||
`orThrow` sendResponseStatus status404 (NotFoundE [i|#{pkg} satisfying #{versionSpec}|])
|
||||
addPackageHeader pkg version
|
||||
(len, src) <- getManifest pkg version
|
||||
addHeader "Content-Length" (show len)
|
||||
respondSource typeJson $ src .| awaitForever sendChunkBS
|
||||
|
||||
getAppR :: Extension "s9pk" -> Handler TypedContent
|
||||
getAppR e = do
|
||||
appResourceDir <- (</> "apps") . resourcesDir . appSettings <$> getYesod
|
||||
getApp appResourceDir e
|
||||
getAppR :: S9PK -> Handler TypedContent
|
||||
getAppR file = do
|
||||
let pkg = PkgId . T.pack $ takeBaseName (show file)
|
||||
versionSpec <- getVersionSpecFromQuery
|
||||
version <- getBestVersion pkg versionSpec
|
||||
`orThrow` sendResponseStatus status404 (NotFoundE [i|#{pkg} satisfying #{versionSpec}|])
|
||||
addPackageHeader pkg version
|
||||
void $ recordMetrics pkg version
|
||||
(len, src) <- getPackage pkg version
|
||||
addHeader "Content-Length" (show len)
|
||||
respondSource typeOctet $ src .| awaitForever sendChunkBS
|
||||
|
||||
getApp :: KnownSymbol a => FilePath -> Extension a -> Handler TypedContent
|
||||
getApp rootDir ext@(Extension appId) = do
|
||||
specString <- T.filter (not . isSpace) . fromMaybe "*" <$> lookupGetParam "spec"
|
||||
spec <- case readMaybe specString of
|
||||
Nothing -> sendResponseStatus status400 ("Invalid App Version Specification" :: Text)
|
||||
Just t -> pure t
|
||||
appVersions <- liftIO $ getAvailableAppVersions rootDir ext
|
||||
putStrLn $ "valid appversion for " <> (show ext :: String) <> ": " <> show appVersions
|
||||
let satisfactory = filter ((<|| spec) . fst . unRegisteredAppVersion) appVersions
|
||||
let best = fst . getMaxVersion <$> foldMap (Just . MaxVersion . (, fst . unRegisteredAppVersion)) satisfactory
|
||||
(appsDir, appMgrDir) <- getsYesod $ ((</> "apps") . resourcesDir &&& staticBinDir) . appSettings
|
||||
case best of
|
||||
Nothing -> notFound
|
||||
Just (RegisteredAppVersion (appVersion, filePath)) -> do
|
||||
exists' <- liftIO $ doesFileExist filePath >>= \case
|
||||
True -> pure Existent
|
||||
False -> pure NonExistent
|
||||
let appDir = (<> "/") . (</> show appVersion) . (</> toS appId) $ appsDir
|
||||
let appExt = Extension (toS appId) :: Extension "s9pk"
|
||||
addPackageHeader appMgrDir appDir appExt
|
||||
determineEvent exists' (extension ext) filePath appVersion
|
||||
where
|
||||
determineEvent :: FileExistence -> String -> FilePath -> Version -> HandlerFor RegistryCtx TypedContent
|
||||
-- for app files
|
||||
determineEvent Existent "s9pk" fp av = do
|
||||
_ <- recordMetrics appId av
|
||||
chunkIt fp
|
||||
-- for png, system, etc
|
||||
determineEvent Existent _ fp _ = chunkIt fp
|
||||
determineEvent NonExistent _ _ _ = notFound
|
||||
|
||||
chunkIt :: FilePath -> HandlerFor RegistryCtx TypedContent
|
||||
chunkIt :: FilePath -> Handler TypedContent
|
||||
chunkIt fp = do
|
||||
sz <- liftIO $ fileSize <$> getFileStatus fp
|
||||
addHeader "Content-Length" (show sz)
|
||||
respondSource typeOctet $ CB.sourceFile fp .| awaitForever sendChunkBS
|
||||
|
||||
recordMetrics :: String -> Version -> HandlerFor RegistryCtx ()
|
||||
recordMetrics appId appVersion = do
|
||||
let appId' = T.pack appId
|
||||
sa <- runDB $ fetchApp $ PkgId appId'
|
||||
recordMetrics :: PkgId -> Version -> Handler ()
|
||||
recordMetrics pkg appVersion = do
|
||||
sa <- runDB $ fetchApp $ pkg
|
||||
case sa of
|
||||
Nothing -> do
|
||||
$logError $ appId' <> " not found in database"
|
||||
$logError $ show pkg <> " not found in database"
|
||||
notFound
|
||||
Just a -> do
|
||||
let appKey' = entityKey a
|
||||
|
||||
@@ -2,6 +2,7 @@
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
@@ -9,23 +10,22 @@ module Handler.Icons where
|
||||
|
||||
import Startlude hiding ( Handler )
|
||||
|
||||
import Yesod.Core
|
||||
|
||||
import Data.Aeson
|
||||
import qualified Data.ByteString.Lazy as BS
|
||||
import Data.Conduit ( (.|)
|
||||
, awaitForever
|
||||
, runConduit
|
||||
)
|
||||
import qualified Data.Conduit.List as CL
|
||||
import Data.String.Interpolate.IsString
|
||||
( i )
|
||||
import Foundation
|
||||
import Lib.External.AppMgr
|
||||
import Lib.Registry
|
||||
import Lib.Error ( S9Error(NotFoundE) )
|
||||
import Lib.PkgRepository ( getBestVersion
|
||||
, getIcon
|
||||
, getInstructions
|
||||
, getLicense
|
||||
)
|
||||
import Lib.Types.AppIndex
|
||||
import Network.HTTP.Types
|
||||
import Settings
|
||||
import System.FilePath.Posix
|
||||
import Util.Shared
|
||||
import Yesod.Core
|
||||
|
||||
data IconType = PNG | JPG | JPEG | SVG
|
||||
deriving (Eq, Show, Generic, Read)
|
||||
@@ -38,66 +38,28 @@ ixt :: Text
|
||||
ixt = toS $ toUpper <$> drop 1 ".png"
|
||||
|
||||
getIconsR :: PkgId -> Handler TypedContent
|
||||
getIconsR appId = do
|
||||
-- (appsDir, appMgrDir) <- getsYesod $ ((</> "apps") . resourcesDir &&& staticBinDir) . appSettings
|
||||
-- spec <- getVersionFromQuery appsDir ext >>= \case
|
||||
-- Nothing -> sendResponseStatus status404 ("Specified App Version Not Found" :: Text)
|
||||
-- Just v -> pure v
|
||||
-- let appDir = (<> "/") . (</> show spec) . (</> show appId) $ appsDir
|
||||
-- manifest' <- sourceManifest appMgrDir appDir ext (\bsSource -> runConduit $ bsSource .| CL.foldMap BS.fromStrict)
|
||||
-- manifest <- case eitherDecode manifest' of
|
||||
-- Left e -> do
|
||||
-- $logError "could not parse service manifest!"
|
||||
-- $logError (show e)
|
||||
-- sendResponseStatus status500 ("Internal Server Error" :: Text)
|
||||
-- Right a -> pure a
|
||||
-- mimeType <- case serviceManifestIcon manifest of
|
||||
-- Nothing -> pure typePng
|
||||
-- Just a -> do
|
||||
-- let (_, iconExt) = splitExtension $ toS a
|
||||
-- let x = toUpper <$> drop 1 iconExt
|
||||
-- case readMaybe $ toS x of
|
||||
-- Nothing -> do
|
||||
-- $logInfo $ "unknown icon extension type: " <> show x <> ". Sending back typePlain."
|
||||
-- pure typePlain
|
||||
-- Just iconType -> case iconType of
|
||||
-- PNG -> pure typePng
|
||||
-- SVG -> pure typeSvg
|
||||
-- JPG -> pure typeJpeg
|
||||
-- JPEG -> pure typeJpeg
|
||||
-- sourceIcon appMgrDir
|
||||
-- (appDir </> show ext)
|
||||
-- ext
|
||||
-- (\bsSource -> respondSource mimeType (bsSource .| awaitForever sendChunkBS))
|
||||
-- where ext = Extension (show appId) :: Extension "s9pk"
|
||||
_
|
||||
getIconsR pkg = do
|
||||
spec <- getVersionSpecFromQuery
|
||||
version <- getBestVersion pkg spec
|
||||
`orThrow` sendResponseStatus status400 (NotFoundE [i|Icon for #{pkg} satisfying #{spec}|])
|
||||
(ct, len, src) <- getIcon pkg version
|
||||
addHeader "Content-Length" (show len)
|
||||
respondSource ct $ src .| awaitForever sendChunkBS
|
||||
|
||||
getLicenseR :: PkgId -> Handler TypedContent
|
||||
getLicenseR appId = do
|
||||
-- (appsDir, appMgrDir) <- getsYesod $ ((</> "apps") . resourcesDir &&& staticBinDir) . appSettings
|
||||
-- spec <- getVersionFromQuery appsDir ext >>= \case
|
||||
-- Nothing -> sendResponseStatus status404 ("Specified App Version Not Found" :: Text)
|
||||
-- Just v -> pure v
|
||||
-- servicePath <- liftIO $ getVersionedFileFromDir appsDir ext spec
|
||||
-- case servicePath of
|
||||
-- Nothing -> notFound
|
||||
-- Just p ->
|
||||
-- sourceLicense appMgrDir p ext (\bsSource -> respondSource typePlain (bsSource .| awaitForever sendChunkBS))
|
||||
-- where ext = Extension (show appId) :: Extension "s9pk"
|
||||
_
|
||||
getLicenseR pkg = do
|
||||
spec <- getVersionSpecFromQuery
|
||||
version <- getBestVersion pkg spec
|
||||
`orThrow` sendResponseStatus status400 (NotFoundE [i|License for #{pkg} satisfying #{spec}|])
|
||||
(len, src) <- getLicense pkg version
|
||||
addHeader "Content-Length" (show len)
|
||||
respondSource typePlain $ src .| awaitForever sendChunkBS
|
||||
|
||||
getInstructionsR :: PkgId -> Handler TypedContent
|
||||
getInstructionsR appId = do
|
||||
-- (appsDir, appMgrDir) <- getsYesod $ ((</> "apps") . resourcesDir &&& staticBinDir) . appSettings
|
||||
-- spec <- getVersionFromQuery appsDir ext >>= \case
|
||||
-- Nothing -> sendResponseStatus status404 ("Specified App Version Not Found" :: Text)
|
||||
-- Just v -> pure v
|
||||
-- servicePath <- liftIO $ getVersionedFileFromDir appsDir ext spec
|
||||
-- case servicePath of
|
||||
-- Nothing -> notFound
|
||||
-- Just p -> sourceInstructions appMgrDir
|
||||
-- p
|
||||
-- ext
|
||||
-- (\bsSource -> respondSource typePlain (bsSource .| awaitForever sendChunkBS))
|
||||
-- where ext = Extension (show appId) :: Extension "s9pk"
|
||||
_
|
||||
getInstructionsR pkg = do
|
||||
spec <- getVersionSpecFromQuery
|
||||
version <- getBestVersion pkg spec
|
||||
`orThrow` sendResponseStatus status400 (NotFoundE [i|Instructions for #{pkg} satisfying #{spec}|])
|
||||
(len, src) <- getInstructions pkg version
|
||||
addHeader "Content-Length" (show len)
|
||||
respondSource typePlain $ src .| awaitForever sendChunkBS
|
||||
|
||||
@@ -12,12 +12,11 @@
|
||||
|
||||
module Handler.Marketplace where
|
||||
import Conduit ( (.|)
|
||||
, MonadThrow
|
||||
, mapC
|
||||
, runConduit
|
||||
)
|
||||
import Data.Aeson
|
||||
import qualified Data.ByteString.Lazy as BS
|
||||
import qualified Data.Conduit.Text as CT
|
||||
import qualified Data.Conduit.List as CL
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import Data.List
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
@@ -30,21 +29,20 @@ import Database.Marketplace
|
||||
import qualified Database.Persist as P
|
||||
import Foundation
|
||||
import Lib.Error
|
||||
import Lib.External.AppMgr
|
||||
import Lib.Registry
|
||||
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 System.FilePath.Posix
|
||||
import UnliftIO.Async
|
||||
import Yesod.Core
|
||||
import Yesod.Persist.Core
|
||||
@@ -242,122 +240,136 @@ getVersionLatestR = do
|
||||
|
||||
getPackageListR :: Handler ServiceAvailableRes
|
||||
getPackageListR = do
|
||||
getParameters <- reqGetParams <$> getRequest
|
||||
let defaults = ServiceListDefaults { serviceListOrder = DESC
|
||||
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 = ""
|
||||
}
|
||||
case lookup "ids" getParameters of
|
||||
Nothing -> do
|
||||
-- query for all
|
||||
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 $ Just 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"
|
||||
filteredServices <- runDB $ searchServices category limit' ((page - 1) * limit') query
|
||||
let filteredServices' = sAppAppId . entityVal <$> filteredServices
|
||||
settings <- getsYesod appSettings
|
||||
packageMetadata <- runDB $ fetchPackageMetadata
|
||||
serviceDetailResult <- liftIO
|
||||
$ mapConcurrently (getServiceDetails settings packageMetadata Nothing) filteredServices'
|
||||
let (_, services) = partitionEithers serviceDetailResult
|
||||
pure $ ServiceAvailableRes services
|
||||
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)
|
||||
|
||||
Just packageVersionList -> case eitherDecode $ BS.fromStrict $ encodeUtf8 packageVersionList of
|
||||
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
|
||||
-- @TODO fix _ error
|
||||
packageMetadata <- runDB $ fetchPackageMetadata
|
||||
availableServicesResult <- traverse (getPackageDetails packageMetadata) packages
|
||||
let (_, availableServices) = partitionEithers availableServicesResult
|
||||
serviceDetailResult <- liftIO
|
||||
$ mapConcurrently (uncurry $ getServiceDetails settings packageMetadata) availableServices
|
||||
-- @TODO fix _ error
|
||||
let (_, services) = partitionEithers serviceDetailResult
|
||||
pure $ ServiceAvailableRes services
|
||||
where
|
||||
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, MonadError IOException m)
|
||||
getServiceDetails :: (MonadUnliftIO m, Monad m, MonadResource m)
|
||||
=> AppSettings
|
||||
-> (HM.HashMap PkgId ([Version], [CategoryTitle]))
|
||||
-> Maybe Version
|
||||
-> PkgId
|
||||
-> m (Either Text ServiceRes)
|
||||
getServiceDetails settings metadata maybeVersion appId = do
|
||||
-- packageMetadata <- case HM.lookup appId metadata of
|
||||
-- Nothing -> throwIO $ NotFoundE [i|#{appId} not found.|]
|
||||
-- Just m -> pure m
|
||||
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 (appsDir, appMgrDir) = ((</> "apps") . resourcesDir &&& staticBinDir) settings
|
||||
-- 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 appId
|
||||
-- x : _ -> pure x
|
||||
-- Just v -> pure v
|
||||
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
|
||||
-- let appDir = (<> "/") . (</> show version) . (</> show appId) $ appsDir
|
||||
-- let appExt = Extension (show appId) :: Extension "s9pk"
|
||||
-- manifest' <- sourceManifest appMgrDir appDir appExt (\bs -> sinkMem (bs .| mapC BS.fromStrict))
|
||||
-- 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 domain metadata)
|
||||
-- (HM.toList $ serviceManifestDependencies m)
|
||||
-- pure $ Right $ ServiceRes { serviceResIcon = [i|https://#{domain}/package/icon/#{appId}|]
|
||||
-- , 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}|]
|
||||
-- , serviceResVersions = fst packageMetadata
|
||||
-- , serviceResDependencyInfo = HM.fromList $ snd $ partitionEithers d
|
||||
-- }
|
||||
_
|
||||
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
|
||||
|
||||
@@ -8,31 +8,20 @@ import Startlude hiding ( toLower )
|
||||
import Data.Aeson
|
||||
import Yesod.Core.Content
|
||||
|
||||
import Data.Text
|
||||
import Lib.Types.Emver
|
||||
import Orphans.Emver ( )
|
||||
import Data.Text
|
||||
|
||||
data AppVersionRes = AppVersionRes
|
||||
{ appVersionVersion :: Version
|
||||
, appVersionMinCompanion :: Maybe Version
|
||||
, appVersionReleaseNotes :: Maybe Text
|
||||
{ appVersionVersion :: Version
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
instance ToJSON AppVersionRes where
|
||||
toJSON AppVersionRes { appVersionVersion, appVersionMinCompanion, appVersionReleaseNotes } =
|
||||
let rn = case appVersionReleaseNotes of
|
||||
Nothing -> []
|
||||
Just x -> ["release-notes" .= x]
|
||||
mc = case appVersionMinCompanion of
|
||||
Nothing -> []
|
||||
Just x -> ["minCompanion" .= x]
|
||||
in object $ ["version" .= appVersionVersion] <> mc <> rn
|
||||
toJSON AppVersionRes { appVersionVersion } = object $ ["version" .= appVersionVersion]
|
||||
instance ToContent AppVersionRes where
|
||||
toContent = toContent . toJSON
|
||||
instance ToTypedContent AppVersionRes where
|
||||
toTypedContent = toTypedContent . toJSON
|
||||
|
||||
-- Ugh
|
||||
instance ToContent (Maybe AppVersionRes) where
|
||||
toContent = toContent . toJSON
|
||||
instance ToTypedContent (Maybe AppVersionRes) where
|
||||
@@ -47,9 +36,10 @@ instance ToJSON SystemStatus where
|
||||
toJSON = String . toLower . show
|
||||
|
||||
data OSVersionRes = OSVersionRes
|
||||
{ osVersionStatus :: SystemStatus
|
||||
{ osVersionStatus :: SystemStatus
|
||||
, osVersionVersion :: Version
|
||||
} deriving (Eq, Show)
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
instance ToJSON OSVersionRes where
|
||||
toJSON OSVersionRes {..} = object ["status" .= osVersionStatus, "version" .= osVersionVersion]
|
||||
instance ToContent OSVersionRes where
|
||||
|
||||
@@ -2,52 +2,51 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
module Handler.Version where
|
||||
|
||||
import Startlude hiding ( Handler )
|
||||
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Yesod.Core
|
||||
|
||||
import qualified Data.Attoparsec.Text as Atto
|
||||
import Data.String.Interpolate.IsString
|
||||
( i )
|
||||
import qualified Data.Text as T
|
||||
import Foundation
|
||||
import Handler.Types.Status
|
||||
import Lib.Registry
|
||||
import Lib.Types.Emver
|
||||
import Lib.Error ( S9Error(NotFoundE) )
|
||||
import Lib.PkgRepository ( getBestVersion )
|
||||
import Lib.Types.AppIndex ( PkgId )
|
||||
import Lib.Types.Emver ( parseVersion
|
||||
, satisfies
|
||||
)
|
||||
import Network.HTTP.Types.Status ( status404 )
|
||||
import Settings
|
||||
import System.FilePath ( (</>) )
|
||||
import Util.Shared
|
||||
import System.Directory ( doesFileExist )
|
||||
import UnliftIO.Directory ( listDirectory )
|
||||
import Util.Shared ( getVersionSpecFromQuery
|
||||
, orThrow
|
||||
)
|
||||
|
||||
getVersionR :: Handler AppVersionRes
|
||||
getVersionR = do
|
||||
rv <- AppVersionRes . registryVersion . appSettings <$> getYesod
|
||||
pure $ rv Nothing Nothing
|
||||
getVersionR = AppVersionRes . registryVersion . appSettings <$> getYesod
|
||||
|
||||
getVersionAppR :: Text -> Handler (Maybe AppVersionRes)
|
||||
getVersionAppR appId = do
|
||||
(appsDir, appMgrDir) <- getsYesod $ ((</> "apps") . resourcesDir &&& staticBinDir) . appSettings
|
||||
res <- getVersionWSpec appsDir appExt
|
||||
case res of
|
||||
Nothing -> pure res
|
||||
Just r -> do
|
||||
let appDir = (<> "/") . (</> (show $ appVersionVersion r)) . (</> toS appId) $ appsDir
|
||||
addPackageHeader appMgrDir appDir appExt
|
||||
pure res
|
||||
where appExt = Extension (toS appId) :: Extension "s9pk"
|
||||
getPkgVersionR :: PkgId -> Handler AppVersionRes
|
||||
getPkgVersionR pkg = do
|
||||
spec <- getVersionSpecFromQuery
|
||||
AppVersionRes <$> getBestVersion pkg spec `orThrow` sendResponseStatus
|
||||
status404
|
||||
(NotFoundE [i|Version for #{pkg} satisfying #{spec}|])
|
||||
|
||||
-- @TODO - deprecate
|
||||
getVersionSysR :: Text -> Handler (Maybe AppVersionRes)
|
||||
getVersionSysR sysAppId = runMaybeT $ do
|
||||
sysDir <- (</> "sys") . resourcesDir . appSettings <$> getYesod
|
||||
avr <- MaybeT $ getVersionWSpec sysDir sysExt
|
||||
let notesPath = sysDir </> "agent" </> show (appVersionVersion avr) </> "release-notes.md"
|
||||
notes <- liftIO $ ifM (doesFileExist notesPath) (Just <$> readFile notesPath) (pure Nothing)
|
||||
pure $ avr { appVersionMinCompanion = Just $ Version (1, 1, 0, 0), appVersionReleaseNotes = notes }
|
||||
where sysExt = Extension (toS sysAppId) :: Extension ""
|
||||
|
||||
getVersionWSpec :: KnownSymbol a => FilePath -> Extension a -> Handler (Maybe AppVersionRes)
|
||||
getVersionWSpec rootDir ext = do
|
||||
av <- getVersionFromQuery rootDir ext
|
||||
pure $ liftA3 AppVersionRes av (pure Nothing) (pure Nothing)
|
||||
getEosVersionR :: Handler AppVersionRes
|
||||
getEosVersionR = do
|
||||
spec <- getVersionSpecFromQuery
|
||||
root <- getsYesod $ (</> "eos") . resourcesDir . appSettings
|
||||
subdirs <- listDirectory root
|
||||
let (failures, successes) = partitionEithers $ (Atto.parseOnly parseVersion . T.pack) <$> subdirs
|
||||
for_ failures $ \f -> $logWarn [i|Emver Parse Failure for EOS: #{f}|]
|
||||
let res = headMay . sortOn Down . filter (`satisfies` spec) $ successes
|
||||
maybe (sendResponseStatus status404 (NotFoundE [i|EOS version satisfying #{spec}|])) (pure . AppVersionRes) res
|
||||
|
||||
Reference in New Issue
Block a user