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

builds

Browse Source
This commit is contained in:
Keagan McClelland
2021-09-28 15:43:56 -06:00
parent e7ebd02be0
commit bcc3f01086
13 changed files with 377 additions and 360 deletions
Download Patch File Download Diff File Expand all files Collapse all files

10
config/routes
View File

@@ -2,18 +2,14 @@
/package/data CategoriesR GET -- get all marketplace categories
/package/index PackageListR GET -- filter marketplace services by various query params
-- /package/updates
/eos/latest EosR GET -- get eos information
/eos/latest EosVersionR GET -- get eos information
/eos/eos.img EosR GET -- get eos.img
/latest-version VersionLatestR GET -- get latest version of apps in query param id
/package/manifest/#PkgId AppManifestR GET -- get app manifest from appmgr -- ?version={semver-spec}
/package/release-notes ReleaseNotesR GET -- get release notes for package - expects query param of id=<pacakge-id>
/package/icon/#PkgId IconsR GET -- get icons - can specify version with ?spec=<emver>
/package/license/#PkgId LicenseR GET -- get icons - can specify version with ?spec=<emver>
/package/instructions/#PkgId InstructionsR GET -- get icons - can specify version with ?spec=<emver>
-- TODO confirm needed
/package/version/#Text VersionAppR GET -- get most recent appId version
!/sys/#SYS_EXTENSIONLESS SysR GET -- get most recent sys app -- ?spec={semver-spec}
/version VersionR GET
/sys/version/#Text VersionSysR GET -- get most recent sys app version
/package/version/#PkgId PkgVersionR GET -- get most recent appId version
/error-logs ErrorLogsR POST

14
src/Foundation.hs
View File

@@ -9,10 +9,13 @@ module Foundation where
import Startlude hiding ( Handler )
import Control.Monad.Logger ( LogSource )
import Database.Persist.Sql
import Database.Persist.Sql hiding ( update )
import Lib.Registry
import Yesod.Core
import Yesod.Core.Types ( Logger )
import Yesod.Core.Types ( HandlerData(handlerEnv)
, Logger
, RunHandlerEnv(rheChild, rheSite)
)
import qualified Yesod.Core.Unsafe as Unsafe
import Control.Monad.Reader.Has ( Has(extract, update) )
@@ -43,6 +46,13 @@ instance Has PkgRepo RegistryCtx where
let repo = f $ extract ctx
settings = (appSettings ctx) { resourcesDir = pkgRepoFileRoot repo, staticBinDir = pkgRepoAppMgrBin repo }
in ctx { appSettings = settings }
instance Has PkgRepo (HandlerData RegistryCtx RegistryCtx) where
extract = extract . rheSite . handlerEnv
update f r =
let ctx = update f (rheSite $ handlerEnv r)
rhe = (handlerEnv r) { rheSite = ctx, rheChild = ctx }
in r { handlerEnv = rhe }

153
src/Handler/Apps.hs
View File

@@ -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

100
src/Handler/Icons.hs
View File

@@ -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

228
src/Handler/Marketplace.hs
View File

@@ -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

22
src/Handler/Types/Status.hs
View File

@@ -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

65
src/Handler/Version.hs
View File

@@ -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

16
src/Lib/Error.hs
View File

@@ -15,6 +15,7 @@ data S9Error =
PersistentE Text
| AppMgrE Text ExitCode
| NotFoundE Text
| InvalidParamsE Text Text
deriving (Show, Eq)
instance Exception S9Error
@@ -22,14 +23,16 @@ instance Exception S9Error
-- | Redact any sensitive data in this function
toError :: S9Error -> Error
toError = \case
PersistentE t -> Error DATABASE_ERROR t
AppMgrE cmd code -> Error APPMGR_ERROR [i|"appmgr #{cmd}" exited with #{code}|]
NotFoundE e -> Error NOT_FOUND [i|#{e}|]
PersistentE t -> Error DATABASE_ERROR t
AppMgrE cmd code -> Error APPMGR_ERROR [i|"appmgr #{cmd}" exited with #{code}|]
NotFoundE e -> Error NOT_FOUND [i|#{e}|]
InvalidParamsE e m -> Error INVALID_PARAMS [i|Could not parse request parameters #{e}: #{m}|]
data ErrorCode =
DATABASE_ERROR
| APPMGR_ERROR
| NOT_FOUND
| INVALID_PARAMS
deriving (Eq, Show)
instance ToJSON ErrorCode where
@@ -54,9 +57,10 @@ instance ToContent S9Error where
toStatus :: S9Error -> Status
toStatus = \case
PersistentE _ -> status500
AppMgrE _ _ -> status500
NotFoundE _ -> status404
PersistentE _ -> status500
AppMgrE _ _ -> status500
NotFoundE _ -> status404
InvalidParamsE _ _ -> status400
handleS9ErrT :: MonadHandler m => S9ErrT m a -> m a

1
src/Lib/External/AppMgr.hs vendored
View File

@@ -23,7 +23,6 @@ import Conduit ( (.|)
import qualified Data.Conduit.List as CL
import Data.Conduit.Process.Typed
import Lib.Error
import Lib.Registry
import System.FilePath ( (</>) )
import UnliftIO ( MonadUnliftIO
, catch

69
src/Lib/PkgRepository.hs
View File

@@ -28,6 +28,9 @@ import Control.Monad.Reader.Has ( Has
)
import Data.Aeson ( eitherDecodeFileStrict' )
import qualified Data.Attoparsec.Text as Atto
import Data.ByteString ( readFile
, writeFile
)
import Data.String.Interpolate.IsString
( i )
import qualified Data.Text as T
@@ -37,7 +40,9 @@ import Lib.Types.AppIndex ( PkgId(..)
, ServiceManifest(serviceManifestIcon)
)
import Lib.Types.Emver ( Version
, VersionRange
, parseVersion
, satisfies
)
import Startlude ( ($)
, (&&)
@@ -46,11 +51,13 @@ import Startlude ( ($)
, (<>)
, Bool(..)
, ByteString
, Down(Down)
, Either(Left, Right)
, Eq((==))
, Exception
, FilePath
, IO
, Integer
, Maybe(Just, Nothing)
, MonadIO(liftIO)
, MonadReader
@@ -59,10 +66,12 @@ import Startlude ( ($)
, find
, for_
, fromMaybe
, headMay
, not
, partitionEithers
, pure
, show
, sortOn
, throwIO
)
import System.FSNotify ( Event(Added)
@@ -87,7 +96,8 @@ import UnliftIO ( MonadUnliftIO
)
import UnliftIO ( tryPutMVar )
import UnliftIO.Concurrent ( forkIO )
import UnliftIO.Directory ( listDirectory
import UnliftIO.Directory ( getFileSize
, listDirectory
, removeFile
, renameFile
)
@@ -116,6 +126,15 @@ getVersionsFor pkg = do
for_ failures $ \f -> $logWarn [i|Emver Parse Failure for #{pkg}: #{f}|]
pure successes
getViableVersions :: (MonadIO m, MonadReader r m, Has PkgRepo r, MonadLogger m) => PkgId -> VersionRange -> m [Version]
getViableVersions pkg spec = filter (`satisfies` spec) <$> getVersionsFor pkg
getBestVersion :: (MonadIO m, MonadReader r m, Has PkgRepo r, MonadLogger m)
=> PkgId
-> VersionRange
-> m (Maybe Version)
getBestVersion pkg spec = headMay . sortOn Down <$> getViableVersions pkg spec
-- extract all package assets into their own respective files
extractPkg :: (MonadUnliftIO m, MonadReader r m, Has PkgRepo r, MonadLoggerIO m) => FilePath -> m ()
extractPkg fp = (`onException` cleanup) $ do
@@ -125,6 +144,7 @@ extractPkg fp = (`onException` cleanup) $ do
-- let s9pk = pkgRoot </> show pkg <.> "s9pk"
manifestTask <- async $ liftIO . runResourceT $ AppMgr.sourceManifest appmgr fp $ sinkIt
(pkgRoot </> "manifest.json")
pkgHashTask <- async $ AppMgr.getPackageHash appmgr fp
instructionsTask <- async $ liftIO . runResourceT $ AppMgr.sourceInstructions appmgr fp $ sinkIt
(pkgRoot </> "instructions.md")
licenseTask <- async $ liftIO . runResourceT $ AppMgr.sourceLicense appmgr fp $ sinkIt (pkgRoot </> "license.md")
@@ -139,6 +159,8 @@ extractPkg fp = (`onException` cleanup) $ do
wait iconTask
let iconDest = "icon" <.> T.unpack (fromMaybe "png" (serviceManifestIcon manifest))
liftIO $ renameFile (pkgRoot </> "icon.tmp") (pkgRoot </> iconDest)
hash <- wait pkgHashTask
liftIO $ writeFile (pkgRoot </> "hash.bin") hash
wait instructionsTask
wait licenseTask
where
@@ -167,28 +189,40 @@ watchPkgRepoRoot = do
Added path _ isDir -> not isDir && takeExtension path == ".s9pk"
_ -> False
getManifest :: (MonadResource m, MonadReader r m, Has PkgRepo r) => PkgId -> Version -> ConduitT () ByteString m ()
getManifest :: (MonadResource m, MonadReader r m, Has PkgRepo r)
=> PkgId
-> Version
-> m (Integer, ConduitT () ByteString m ())
getManifest pkg version = do
root <- asks pkgRepoFileRoot
let manifestPath = root </> show pkg </> show version </> "manifest.json"
sourceFile manifestPath
n <- getFileSize manifestPath
pure $ (n, sourceFile manifestPath)
getInstructions :: (MonadResource m, MonadReader r m, Has PkgRepo r) => PkgId -> Version -> ConduitT () ByteString m ()
getInstructions :: (MonadResource m, MonadReader r m, Has PkgRepo r)
=> PkgId
-> Version
-> m (Integer, ConduitT () ByteString m ())
getInstructions pkg version = do
root <- asks pkgRepoFileRoot
let instructionsPath = root </> show pkg </> show version </> "instructions.md"
sourceFile instructionsPath
n <- getFileSize instructionsPath
pure $ (n, sourceFile instructionsPath)
getLicense :: (MonadResource m, MonadReader r m, Has PkgRepo r) => PkgId -> Version -> ConduitT () ByteString m ()
getLicense :: (MonadResource m, MonadReader r m, Has PkgRepo r)
=> PkgId
-> Version
-> m (Integer, ConduitT () ByteString m ())
getLicense pkg version = do
root <- asks pkgRepoFileRoot
let licensePath = root </> show pkg </> show version </> "license.md"
sourceFile licensePath
n <- getFileSize licensePath
pure $ (n, sourceFile licensePath)
getIcon :: (MonadResource m, MonadReader r m, Has PkgRepo r)
=> PkgId
-> Version
-> m (ContentType, ConduitT () ByteString m ())
-> m (ContentType, Integer, ConduitT () ByteString m ())
getIcon pkg version = do
root <- asks pkgRepoFileRoot
let pkgRoot = root </> show pkg </> show version
@@ -203,4 +237,21 @@ getIcon pkg version = do
".svg" -> typeSvg
".gif" -> typeGif
_ -> typePlain
pure $ (ct, sourceFile (pkgRoot </> x))
n <- getFileSize (pkgRoot </> x)
pure $ (ct, n, sourceFile (pkgRoot </> x))
getHash :: (MonadIO m, MonadReader r m, Has PkgRepo r) => PkgId -> Version -> m ByteString
getHash pkg version = do
root <- asks pkgRepoFileRoot
let hashPath = root </> show pkg </> show version </> "hash.bin"
liftIO $ readFile hashPath
getPackage :: (MonadResource m, MonadReader r m, Has PkgRepo r)
=> PkgId
-> Version
-> m (Integer, ConduitT () ByteString m ())
getPackage pkg version = do
root <- asks pkgRepoFileRoot
let pkgPath = root </> show pkg </> show version </> show pkg <.> "s9pk"
n <- getFileSize pkgPath
pure (n, sourceFile pkgPath)

17
src/Lib/Types/Emver.hs
View File

@@ -34,21 +34,20 @@ module Lib.Types.Emver
, exactly
, parseVersion
, parseRange
)
where
) where
import Prelude
import Control.Applicative ( Alternative((<|>))
, liftA2
)
import Data.Aeson
import qualified Data.Attoparsec.Text as Atto
import Data.Function
import Data.Functor ( (<&>)
, ($>)
)
import Control.Applicative ( liftA2
, Alternative((<|>))
import Data.Functor ( ($>)
, (<&>)
)
import Data.String ( IsString(..) )
import qualified Data.Text as T
import Data.Aeson
import Prelude
import Startlude ( Hashable )
-- | AppVersion is the core representation of the SemverQuad type.

3
src/Util/Function.hs
View File

@@ -21,3 +21,6 @@ mapFind finder mapping (b : bs) =
(Nothing, Just _) -> Just b
_ -> Nothing
(<<&>>) :: (Functor f, Functor g) => f (g a) -> (a -> b) -> f (g b)
f <<&>> fab = fmap (fmap fab) f

39
src/Util/Shared.hs
View File

@@ -1,4 +1,5 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleContexts #-}
module Util.Shared where
@@ -8,33 +9,27 @@ import qualified Data.Text as T
import Network.HTTP.Types
import Yesod.Core
import Data.Semigroup
import Control.Monad.Reader.Has ( Has )
import Foundation
import Lib.External.AppMgr
import Lib.Registry
import Lib.PkgRepository ( PkgRepo
, getHash
)
import Lib.Types.AppIndex ( PkgId )
import Lib.Types.Emver
getVersionFromQuery :: KnownSymbol a => FilePath -> Extension a -> Handler (Maybe Version)
getVersionFromQuery rootDir ext = do
getVersionSpecFromQuery :: Handler VersionRange
getVersionSpecFromQuery = do
specString <- T.filter (not . isSpace) . fromMaybe "*" <$> lookupGetParam "spec"
spec <- case readMaybe specString of
case readMaybe specString of
Nothing -> sendResponseStatus status400 ("Invalid App Version Specification" :: Text)
Just t -> pure t
getBestVersion rootDir ext spec
getBestVersion :: (MonadIO m, KnownSymbol a, MonadLogger m)
=> FilePath
-> Extension a
-> VersionRange
-> m (Maybe Version)
getBestVersion rootDir ext spec = do
-- @TODO change to db query?
appVersions <- liftIO $ getAvailableAppVersions rootDir ext
let satisfactory = filter ((<|| spec) . fst . unRegisteredAppVersion) appVersions
let best = getMax <$> foldMap (Just . Max . fst . unRegisteredAppVersion) satisfactory
pure best
addPackageHeader :: (MonadUnliftIO m, MonadHandler m) => FilePath -> FilePath -> S9PK -> m ()
addPackageHeader appMgrDir appDir appExt = do
packageHash <- getPackageHash appMgrDir appDir appExt
addPackageHeader :: (MonadUnliftIO m, MonadHandler m, MonadReader r m, Has PkgRepo r) => PkgId -> Version -> m ()
addPackageHeader pkg version = do
packageHash <- getHash pkg version
addHeader "X-S9PK-HASH" $ decodeUtf8 packageHash
orThrow :: MonadHandler m => m (Maybe a) -> m a -> m a
orThrow action other = action >>= \case
Nothing -> other
Just x -> pure x