diff --git a/config/routes b/config/routes index d87e1be..eaa6d1d 100644 --- a/config/routes +++ b/config/routes @@ -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= /package/icon/#PkgId IconsR GET -- get icons - can specify version with ?spec= /package/license/#PkgId LicenseR GET -- get icons - can specify version with ?spec= /package/instructions/#PkgId InstructionsR GET -- get icons - can specify version with ?spec= - --- 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 \ No newline at end of file diff --git a/src/Foundation.hs b/src/Foundation.hs index 11a8f7e..33e586e 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -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 } + diff --git a/src/Handler/Apps.hs b/src/Handler/Apps.hs index b2c401a..bfec546 100644 --- a/src/Handler/Apps.hs +++ b/src/Handler/Apps.hs @@ -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 diff --git a/src/Handler/Icons.hs b/src/Handler/Icons.hs index 6ba81cf..6333bd7 100644 --- a/src/Handler/Icons.hs +++ b/src/Handler/Icons.hs @@ -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 diff --git a/src/Handler/Marketplace.hs b/src/Handler/Marketplace.hs index 7c04156..2fac927 100644 --- a/src/Handler/Marketplace.hs +++ b/src/Handler/Marketplace.hs @@ -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 diff --git a/src/Handler/Types/Status.hs b/src/Handler/Types/Status.hs index 51b56f7..5c23e79 100644 --- a/src/Handler/Types/Status.hs +++ b/src/Handler/Types/Status.hs @@ -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 diff --git a/src/Handler/Version.hs b/src/Handler/Version.hs index 74cd75f..100aa53 100644 --- a/src/Handler/Version.hs +++ b/src/Handler/Version.hs @@ -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 diff --git a/src/Lib/Error.hs b/src/Lib/Error.hs index f743558..4e73dbc 100644 --- a/src/Lib/Error.hs +++ b/src/Lib/Error.hs @@ -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 diff --git a/src/Lib/External/AppMgr.hs b/src/Lib/External/AppMgr.hs index 70a6ab0..a49fb90 100644 --- a/src/Lib/External/AppMgr.hs +++ b/src/Lib/External/AppMgr.hs @@ -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 diff --git a/src/Lib/PkgRepository.hs b/src/Lib/PkgRepository.hs index 1c83329..b062d93 100644 --- a/src/Lib/PkgRepository.hs +++ b/src/Lib/PkgRepository.hs @@ -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) diff --git a/src/Lib/Types/Emver.hs b/src/Lib/Types/Emver.hs index 0c9a356..014595a 100644 --- a/src/Lib/Types/Emver.hs +++ b/src/Lib/Types/Emver.hs @@ -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. diff --git a/src/Util/Function.hs b/src/Util/Function.hs index cb5c771..fb20345 100644 --- a/src/Util/Function.hs +++ b/src/Util/Function.hs @@ -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 + diff --git a/src/Util/Shared.hs b/src/Util/Shared.hs index 4eb3c41..58b370e 100644 --- a/src/Util/Shared.hs +++ b/src/Util/Shared.hs @@ -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