Start9/registry
2
0
Fork 0
mirror of https://github.com/Start9Labs/registry.git synced 2026-03-30 19:54:47 +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/data CategoriesR GET -- get all marketplace categories
/package/index PackageListR GET -- filter marketplace services by various query params /package/index PackageListR GET -- filter marketplace services by various query params
-- /package/updates -- /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 /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/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/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/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/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> /package/instructions/#PkgId InstructionsR GET -- get icons - can specify version with ?spec=<emver>
/package/version/#PkgId PkgVersionR GET -- get most recent appId version
-- 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
/error-logs ErrorLogsR POST /error-logs ErrorLogsR POST

14
src/Foundation.hs
View File

@@ -9,10 +9,13 @@ module Foundation where
import Startlude hiding ( Handler ) import Startlude hiding ( Handler )
import Control.Monad.Logger ( LogSource ) import Control.Monad.Logger ( LogSource )
import Database.Persist.Sql import Database.Persist.Sql hiding ( update )
import Lib.Registry import Lib.Registry
import Yesod.Core 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 qualified Yesod.Core.Unsafe as Unsafe
import Control.Monad.Reader.Has ( Has(extract, update) ) import Control.Monad.Reader.Has ( Has(extract, update) )
@@ -43,6 +46,13 @@ instance Has PkgRepo RegistryCtx where
let repo = f $ extract ctx let repo = f $ extract ctx
settings = (appSettings ctx) { resourcesDir = pkgRepoFileRoot repo, staticBinDir = pkgRepoAppMgrBin repo } settings = (appSettings ctx) { resourcesDir = pkgRepoFileRoot repo, staticBinDir = pkgRepoAppMgrBin repo }
in ctx { appSettings = settings } 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 Startlude hiding ( Handler )
import Control.Monad.Logger import Control.Monad.Logger ( logError
import Data.Aeson , logInfo
)
import Data.Aeson ( ToJSON
, encode
)
import qualified Data.Attoparsec.Text as Atto import qualified Data.Attoparsec.Text as Atto
import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy as BS
import Data.Conduit
import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.Binary as CB
import qualified Data.Text as T import qualified Data.Text as T
import Database.Persist import Database.Persist ( Entity(entityKey) )
import qualified GHC.Show ( Show(..) ) import qualified GHC.Show ( Show(..) )
import Network.HTTP.Types import Network.HTTP.Types ( status404 )
import System.Directory
import System.FilePath ( (<.>) import System.FilePath ( (<.>)
, (</>) , takeBaseName
) )
import System.Posix.Files ( fileSize import System.Posix.Files ( fileSize
, getFileStatus , getFileStatus
) )
import Yesod.Core import Yesod.Core ( MonadHandler(HandlerSite)
import Yesod.Persist.Core , TypedContent
, addHeader
, getYesod
, notFound
, respondSource
, sendChunkBS
, sendResponseStatus
, typeJson
, typeOctet
, waiRequest
)
import Yesod.Persist.Core ( YesodPersist(runDB) )
import Database.Queries import Conduit ( (.|)
import Foundation , awaitForever
import Lib.External.AppMgr )
import Lib.Registry import Data.String.Interpolate.IsString
import Lib.Types.AppIndex ( i )
import Lib.Types.Emver import Database.Queries ( createMetric
import Lib.Types.FileSystem , 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 Network.Wai ( Request(requestHeaderUserAgent) )
import Settings import Util.Shared ( addPackageHeader
import Util.Shared , getVersionSpecFromQuery
, orThrow
)
pureLog :: Show a => a -> Handler a pureLog :: Show a => a -> Handler a
pureLog = liftA2 (*>) ($logInfo . show) pure pureLog = liftA2 (*>) ($logInfo . show) pure
@@ -48,6 +76,11 @@ pureLog = liftA2 (*>) ($logInfo . show) pure
logRet :: ToJSON a => Handler a -> Handler a logRet :: ToJSON a => Handler a -> Handler a
logRet = (>>= liftA2 (*>) ($logInfo . decodeUtf8 . BS.toStrict . encode) pure) 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) data FileExtension = FileExtension FilePath (Maybe String)
instance Show FileExtension where instance Show FileExtension where
show (FileExtension f Nothing ) = f show (FileExtension f Nothing ) = f
@@ -64,76 +97,40 @@ getEmbassyOsVersion = userAgentOsVersion
userAgentOsVersion = userAgentOsVersion =
(hush . Atto.parseOnly userAgentOsVersionParser . decodeUtf8 <=< requestHeaderUserAgent) <$> waiRequest (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 :: PkgId -> Handler TypedContent
getAppManifestR appId = do getAppManifestR pkg = do
-- (appsDir, appMgrDir) <- getsYesod $ ((</> "apps") . resourcesDir &&& staticBinDir) . appSettings versionSpec <- getVersionSpecFromQuery
-- av <- getVersionFromQuery appsDir appExt >>= \case version <- getBestVersion pkg versionSpec
-- Nothing -> sendResponseStatus status404 ("Specified App Version Not Found" :: Text) `orThrow` sendResponseStatus status404 (NotFoundE [i|#{pkg} satisfying #{versionSpec}|])
-- Just v -> pure v addPackageHeader pkg version
-- let appDir = (<> "/") . (</> show av) . (</> show appId) $ appsDir (len, src) <- getManifest pkg version
-- addPackageHeader appMgrDir appDir appExt addHeader "Content-Length" (show len)
-- sourceManifest appMgrDir respondSource typeJson $ src .| awaitForever sendChunkBS
-- appDir
-- appExt
-- (\bsSource -> respondSource "application/json" (bsSource .| awaitForever sendChunkBS))
-- where appExt = Extension (show appId) :: Extension "s9pk"
_
getAppR :: Extension "s9pk" -> Handler TypedContent getAppR :: S9PK -> Handler TypedContent
getAppR e = do getAppR file = do
appResourceDir <- (</> "apps") . resourcesDir . appSettings <$> getYesod let pkg = PkgId . T.pack $ takeBaseName (show file)
getApp appResourceDir e 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 chunkIt :: FilePath -> 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 fp = do chunkIt fp = do
sz <- liftIO $ fileSize <$> getFileStatus fp sz <- liftIO $ fileSize <$> getFileStatus fp
addHeader "Content-Length" (show sz) addHeader "Content-Length" (show sz)
respondSource typeOctet $ CB.sourceFile fp .| awaitForever sendChunkBS respondSource typeOctet $ CB.sourceFile fp .| awaitForever sendChunkBS
recordMetrics :: String -> Version -> HandlerFor RegistryCtx () recordMetrics :: PkgId -> Version -> Handler ()
recordMetrics appId appVersion = do recordMetrics pkg appVersion = do
let appId' = T.pack appId sa <- runDB $ fetchApp $ pkg
sa <- runDB $ fetchApp $ PkgId appId'
case sa of case sa of
Nothing -> do Nothing -> do
$logError $ appId' <> " not found in database" $logError $ show pkg <> " not found in database"
notFound notFound
Just a -> do Just a -> do
let appKey' = entityKey a let appKey' = entityKey a

100
src/Handler/Icons.hs
View File

@@ -2,6 +2,7 @@
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
@@ -9,23 +10,22 @@ module Handler.Icons where
import Startlude hiding ( Handler ) import Startlude hiding ( Handler )
import Yesod.Core
import Data.Aeson
import qualified Data.ByteString.Lazy as BS
import Data.Conduit ( (.|) import Data.Conduit ( (.|)
, awaitForever , awaitForever
, runConduit
) )
import qualified Data.Conduit.List as CL import Data.String.Interpolate.IsString
( i )
import Foundation import Foundation
import Lib.External.AppMgr import Lib.Error ( S9Error(NotFoundE) )
import Lib.Registry import Lib.PkgRepository ( getBestVersion
, getIcon
, getInstructions
, getLicense
)
import Lib.Types.AppIndex import Lib.Types.AppIndex
import Network.HTTP.Types import Network.HTTP.Types
import Settings
import System.FilePath.Posix
import Util.Shared import Util.Shared
import Yesod.Core
data IconType = PNG | JPG | JPEG | SVG data IconType = PNG | JPG | JPEG | SVG
deriving (Eq, Show, Generic, Read) deriving (Eq, Show, Generic, Read)
@@ -38,66 +38,28 @@ ixt :: Text
ixt = toS $ toUpper <$> drop 1 ".png" ixt = toS $ toUpper <$> drop 1 ".png"
getIconsR :: PkgId -> Handler TypedContent getIconsR :: PkgId -> Handler TypedContent
getIconsR appId = do getIconsR pkg = do
-- (appsDir, appMgrDir) <- getsYesod $ ((</> "apps") . resourcesDir &&& staticBinDir) . appSettings spec <- getVersionSpecFromQuery
-- spec <- getVersionFromQuery appsDir ext >>= \case version <- getBestVersion pkg spec
-- Nothing -> sendResponseStatus status404 ("Specified App Version Not Found" :: Text) `orThrow` sendResponseStatus status400 (NotFoundE [i|Icon for #{pkg} satisfying #{spec}|])
-- Just v -> pure v (ct, len, src) <- getIcon pkg version
-- let appDir = (<> "/") . (</> show spec) . (</> show appId) $ appsDir addHeader "Content-Length" (show len)
-- manifest' <- sourceManifest appMgrDir appDir ext (\bsSource -> runConduit $ bsSource .| CL.foldMap BS.fromStrict) respondSource ct $ src .| awaitForever sendChunkBS
-- 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"
_
getLicenseR :: PkgId -> Handler TypedContent getLicenseR :: PkgId -> Handler TypedContent
getLicenseR appId = do getLicenseR pkg = do
-- (appsDir, appMgrDir) <- getsYesod $ ((</> "apps") . resourcesDir &&& staticBinDir) . appSettings spec <- getVersionSpecFromQuery
-- spec <- getVersionFromQuery appsDir ext >>= \case version <- getBestVersion pkg spec
-- Nothing -> sendResponseStatus status404 ("Specified App Version Not Found" :: Text) `orThrow` sendResponseStatus status400 (NotFoundE [i|License for #{pkg} satisfying #{spec}|])
-- Just v -> pure v (len, src) <- getLicense pkg version
-- servicePath <- liftIO $ getVersionedFileFromDir appsDir ext spec addHeader "Content-Length" (show len)
-- case servicePath of respondSource typePlain $ src .| awaitForever sendChunkBS
-- Nothing -> notFound
-- Just p ->
-- sourceLicense appMgrDir p ext (\bsSource -> respondSource typePlain (bsSource .| awaitForever sendChunkBS))
-- where ext = Extension (show appId) :: Extension "s9pk"
_
getInstructionsR :: PkgId -> Handler TypedContent getInstructionsR :: PkgId -> Handler TypedContent
getInstructionsR appId = do getInstructionsR pkg = do
-- (appsDir, appMgrDir) <- getsYesod $ ((</> "apps") . resourcesDir &&& staticBinDir) . appSettings spec <- getVersionSpecFromQuery
-- spec <- getVersionFromQuery appsDir ext >>= \case version <- getBestVersion pkg spec
-- Nothing -> sendResponseStatus status404 ("Specified App Version Not Found" :: Text) `orThrow` sendResponseStatus status400 (NotFoundE [i|Instructions for #{pkg} satisfying #{spec}|])
-- Just v -> pure v (len, src) <- getInstructions pkg version
-- servicePath <- liftIO $ getVersionedFileFromDir appsDir ext spec addHeader "Content-Length" (show len)
-- case servicePath of respondSource typePlain $ src .| awaitForever sendChunkBS
-- Nothing -> notFound
-- Just p -> sourceInstructions appMgrDir
-- p
-- ext
-- (\bsSource -> respondSource typePlain (bsSource .| awaitForever sendChunkBS))
-- where ext = Extension (show appId) :: Extension "s9pk"
_

228
src/Handler/Marketplace.hs
View File

@@ -12,12 +12,11 @@
module Handler.Marketplace where module Handler.Marketplace where
import Conduit ( (.|) import Conduit ( (.|)
, MonadThrow , runConduit
, mapC
) )
import Data.Aeson import Data.Aeson
import qualified Data.ByteString.Lazy as BS 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 qualified Data.HashMap.Strict as HM
import Data.List import Data.List
import qualified Data.List.NonEmpty as NE import qualified Data.List.NonEmpty as NE
@@ -30,21 +29,20 @@ import Database.Marketplace
import qualified Database.Persist as P import qualified Database.Persist as P
import Foundation import Foundation
import Lib.Error import Lib.Error
import Lib.External.AppMgr import Lib.PkgRepository ( getManifest )
import Lib.Registry
import Lib.Types.AppIndex import Lib.Types.AppIndex
import Lib.Types.AppIndex ( ) import Lib.Types.AppIndex ( )
import Lib.Types.Category import Lib.Types.Category
import Lib.Types.Emver import Lib.Types.Emver
import Model import Model
import Network.HTTP.Types import Network.HTTP.Types
import Protolude.Unsafe ( unsafeFromJust )
import Settings import Settings
import Startlude hiding ( Handler import Startlude hiding ( Handler
, from , from
, on , on
, sortOn , sortOn
) )
import System.FilePath.Posix
import UnliftIO.Async import UnliftIO.Async
import Yesod.Core import Yesod.Core
import Yesod.Persist.Core import Yesod.Persist.Core
@@ -242,122 +240,136 @@ getVersionLatestR = do
getPackageListR :: Handler ServiceAvailableRes getPackageListR :: Handler ServiceAvailableRes
getPackageListR = do getPackageListR = do
getParameters <- reqGetParams <$> getRequest pkgIds <- getPkgIdsQuery
let defaults = ServiceListDefaults { serviceListOrder = DESC 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 , serviceListPageLimit = 20
, serviceListPageNumber = 1 , serviceListPageNumber = 1
, serviceListCategory = Nothing , serviceListCategory = Nothing
, serviceListQuery = "" , serviceListQuery = ""
} }
case lookup "ids" getParameters of getPkgIdsQuery :: Handler (Maybe [PackageVersion])
Nothing -> do getPkgIdsQuery = lookupGetParam "ids" >>= \case
-- query for all Nothing -> pure Nothing
category <- case lookup "category" getParameters of Just ids -> case eitherDecodeStrict (encodeUtf8 ids) of
Nothing -> pure $ serviceListCategory defaults Left _ -> do
Just c -> case readMaybe $ T.toUpper c of let e = InvalidParamsE "get:ids" ids
Nothing -> do $logWarn (show e)
$logInfo c sendResponseStatus status400 e
sendResponseStatus status400 ("could not read category" :: Text) Right a -> pure a
Just t -> pure $ Just t getCategoryQuery :: Handler (Maybe CategoryTitle)
page <- case lookup "page" getParameters of getCategoryQuery = lookupGetParam "category" >>= \case
Nothing -> pure $ serviceListPageNumber defaults Nothing -> pure Nothing
Just p -> case readMaybe p of Just c -> case readMaybe . T.toUpper $ c of
Nothing -> do Nothing -> do
$logInfo p let e = InvalidParamsE "get:category" c
sendResponseStatus status400 ("could not read page" :: Text) $logWarn (show e)
Just t -> pure $ case t of sendResponseStatus status400 e
0 -> 1 -- disallow page 0 so offset is not negative Just t -> pure $ Just t
_ -> t getPageQuery :: Handler Int64
limit' <- case lookup "per-page" getParameters of getPageQuery = lookupGetParam "page" >>= \case
Nothing -> pure $ serviceListPageLimit defaults Nothing -> pure $ serviceListPageNumber defaults
Just c -> case readMaybe $ toS c of Just p -> case readMaybe p of
Nothing -> sendResponseStatus status400 ("could not read per-page" :: Text) Nothing -> do
Just l -> pure l let e = InvalidParamsE "get:page" p
query <- T.filter (not . isSpace) . fromMaybe (serviceListQuery defaults) <$> lookupGetParam "query" $logWarn (show e)
filteredServices <- runDB $ searchServices category limit' ((page - 1) * limit') query sendResponseStatus status400 e
let filteredServices' = sAppAppId . entityVal <$> filteredServices Just t -> pure $ case t of
settings <- getsYesod appSettings 0 -> 1 -- disallow page 0 so offset is not negative
packageMetadata <- runDB $ fetchPackageMetadata _ -> t
serviceDetailResult <- liftIO getLimitQuery :: Handler Int64
$ mapConcurrently (getServiceDetails settings packageMetadata Nothing) filteredServices' getLimitQuery = lookupGetParam "per-page" >>= \case
let (_, services) = partitionEithers serviceDetailResult Nothing -> pure $ serviceListPageLimit defaults
pure $ ServiceAvailableRes services 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 getServiceDetails :: (MonadUnliftIO m, Monad m, MonadResource m)
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)
=> AppSettings => AppSettings
-> (HM.HashMap PkgId ([Version], [CategoryTitle])) -> (HM.HashMap PkgId ([Version], [CategoryTitle]))
-> Maybe Version -> Maybe Version
-> PkgId -> PkgId
-> m (Either Text ServiceRes) -> m (Either Text ServiceRes)
getServiceDetails settings metadata maybeVersion appId = do getServiceDetails settings metadata maybeVersion pkg = do
-- packageMetadata <- case HM.lookup appId metadata of packageMetadata <- case HM.lookup pkg metadata of
-- Nothing -> throwIO $ NotFoundE [i|#{appId} not found.|] Nothing -> throwIO $ NotFoundE [i|#{pkg} not found.|]
-- Just m -> pure m Just m -> pure m
-- let (appsDir, appMgrDir) = ((</> "apps") . resourcesDir &&& staticBinDir) settings -- let (appsDir, appMgrDir) = ((</> "apps") . resourcesDir &&& staticBinDir) settings
-- let domain = registryHostname settings let domain = registryHostname settings
-- version <- case maybeVersion of version <- case maybeVersion of
-- Nothing -> do Nothing -> do
-- -- grab first value, which will be the latest version -- grab first value, which will be the latest version
-- case fst packageMetadata of case fst packageMetadata of
-- [] -> throwIO $ NotFoundE $ "no latest version found for " <> show appId [] -> throwIO $ NotFoundE $ "no latest version found for " <> show pkg
-- x : _ -> pure x x : _ -> pure x
-- Just v -> pure v Just v -> pure v
-- let appDir = (<> "/") . (</> show version) . (</> show appId) $ appsDir -- let appDir = (<> "/") . (</> show version) . (</> show appId) $ appsDir
-- let appExt = Extension (show appId) :: Extension "s9pk" -- let appExt = Extension (show appId) :: Extension "s9pk"
-- manifest' <- sourceManifest appMgrDir appDir appExt (\bs -> sinkMem (bs .| mapC BS.fromStrict)) manifest <- flip runReaderT settings $ (snd <$> getManifest pkg version) >>= \bs ->
-- case eitherDecode $ manifest' of runConduit $ bs .| CL.foldMap BS.fromStrict
-- Left e -> pure $ Left $ "Could not parse service manifest for " <> show appId <> ": " <> show e case eitherDecode manifest of
-- Right m -> do Left e -> pure $ Left $ "Could not parse service manifest for " <> show pkg <> ": " <> show e
-- d <- liftIO $ mapConcurrently (mapDependencyMetadata domain metadata) Right m -> do
-- (HM.toList $ serviceManifestDependencies m) d <- liftIO $ mapConcurrently (mapDependencyMetadata domain metadata)
-- pure $ Right $ ServiceRes { serviceResIcon = [i|https://#{domain}/package/icon/#{appId}|] (HM.toList $ serviceManifestDependencies m)
-- , serviceResManifest = decode $ manifest' -- pass through raw JSON Value pure $ Right $ ServiceRes { serviceResIcon = [i|https://#{domain}/package/icon/#{pkg}|]
-- , serviceResCategories = snd packageMetadata -- pass through raw JSON Value, we have checked its correct parsing above
-- , serviceResInstructions = [i|https://#{domain}/package/instructions/#{appId}|] , serviceResManifest = unsafeFromJust . decode $ manifest
-- , serviceResLicense = [i|https://#{domain}/package/license/#{appId}|] , serviceResCategories = snd packageMetadata
-- , serviceResVersions = fst packageMetadata , serviceResInstructions = [i|https://#{domain}/package/instructions/#{pkg}|]
-- , serviceResDependencyInfo = HM.fromList $ snd $ partitionEithers d , serviceResLicense = [i|https://#{domain}/package/license/#{pkg}|]
-- } , serviceResVersions = fst packageMetadata
_ , serviceResDependencyInfo = HM.fromList $ snd $ partitionEithers d
}
mapDependencyMetadata :: (MonadIO m) mapDependencyMetadata :: (MonadIO m)
=> Text => Text

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

@@ -8,31 +8,20 @@ import Startlude hiding ( toLower )
import Data.Aeson import Data.Aeson
import Yesod.Core.Content import Yesod.Core.Content
import Data.Text
import Lib.Types.Emver import Lib.Types.Emver
import Orphans.Emver ( ) import Orphans.Emver ( )
import Data.Text
data AppVersionRes = AppVersionRes data AppVersionRes = AppVersionRes
{ appVersionVersion :: Version { appVersionVersion :: Version
, appVersionMinCompanion :: Maybe Version
, appVersionReleaseNotes :: Maybe Text
} }
deriving (Eq, Show) deriving (Eq, Show)
instance ToJSON AppVersionRes where instance ToJSON AppVersionRes where
toJSON AppVersionRes { appVersionVersion, appVersionMinCompanion, appVersionReleaseNotes } = toJSON AppVersionRes { appVersionVersion } = object $ ["version" .= appVersionVersion]
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
instance ToContent AppVersionRes where instance ToContent AppVersionRes where
toContent = toContent . toJSON toContent = toContent . toJSON
instance ToTypedContent AppVersionRes where instance ToTypedContent AppVersionRes where
toTypedContent = toTypedContent . toJSON toTypedContent = toTypedContent . toJSON
-- Ugh
instance ToContent (Maybe AppVersionRes) where instance ToContent (Maybe AppVersionRes) where
toContent = toContent . toJSON toContent = toContent . toJSON
instance ToTypedContent (Maybe AppVersionRes) where instance ToTypedContent (Maybe AppVersionRes) where
@@ -47,9 +36,10 @@ instance ToJSON SystemStatus where
toJSON = String . toLower . show toJSON = String . toLower . show
data OSVersionRes = OSVersionRes data OSVersionRes = OSVersionRes
{ osVersionStatus :: SystemStatus { osVersionStatus :: SystemStatus
, osVersionVersion :: Version , osVersionVersion :: Version
} deriving (Eq, Show) }
deriving (Eq, Show)
instance ToJSON OSVersionRes where instance ToJSON OSVersionRes where
toJSON OSVersionRes {..} = object ["status" .= osVersionStatus, "version" .= osVersionVersion] toJSON OSVersionRes {..} = object ["status" .= osVersionStatus, "version" .= osVersionVersion]
instance ToContent OSVersionRes where instance ToContent OSVersionRes where

65
src/Handler/Version.hs
View File

@@ -2,52 +2,51 @@
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
module Handler.Version where module Handler.Version where
import Startlude hiding ( Handler ) import Startlude hiding ( Handler )
import Control.Monad.Trans.Maybe
import Yesod.Core 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 Foundation
import Handler.Types.Status import Handler.Types.Status
import Lib.Registry import Lib.Error ( S9Error(NotFoundE) )
import Lib.Types.Emver import Lib.PkgRepository ( getBestVersion )
import Lib.Types.AppIndex ( PkgId )
import Lib.Types.Emver ( parseVersion
, satisfies
)
import Network.HTTP.Types.Status ( status404 )
import Settings import Settings
import System.FilePath ( (</>) ) import System.FilePath ( (</>) )
import Util.Shared import UnliftIO.Directory ( listDirectory )
import System.Directory ( doesFileExist ) import Util.Shared ( getVersionSpecFromQuery
, orThrow
)
getVersionR :: Handler AppVersionRes getVersionR :: Handler AppVersionRes
getVersionR = do getVersionR = AppVersionRes . registryVersion . appSettings <$> getYesod
rv <- AppVersionRes . registryVersion . appSettings <$> getYesod
pure $ rv Nothing Nothing
getVersionAppR :: Text -> Handler (Maybe AppVersionRes) getPkgVersionR :: PkgId -> Handler AppVersionRes
getVersionAppR appId = do getPkgVersionR pkg = do
(appsDir, appMgrDir) <- getsYesod $ ((</> "apps") . resourcesDir &&& staticBinDir) . appSettings spec <- getVersionSpecFromQuery
res <- getVersionWSpec appsDir appExt AppVersionRes <$> getBestVersion pkg spec `orThrow` sendResponseStatus
case res of status404
Nothing -> pure res (NotFoundE [i|Version for #{pkg} satisfying #{spec}|])
Just r -> do
let appDir = (<> "/") . (</> (show $ appVersionVersion r)) . (</> toS appId) $ appsDir
addPackageHeader appMgrDir appDir appExt
pure res
where appExt = Extension (toS appId) :: Extension "s9pk"
-- @TODO - deprecate getEosVersionR :: Handler AppVersionRes
getVersionSysR :: Text -> Handler (Maybe AppVersionRes) getEosVersionR = do
getVersionSysR sysAppId = runMaybeT $ do spec <- getVersionSpecFromQuery
sysDir <- (</> "sys") . resourcesDir . appSettings <$> getYesod root <- getsYesod $ (</> "eos") . resourcesDir . appSettings
avr <- MaybeT $ getVersionWSpec sysDir sysExt subdirs <- listDirectory root
let notesPath = sysDir </> "agent" </> show (appVersionVersion avr) </> "release-notes.md" let (failures, successes) = partitionEithers $ (Atto.parseOnly parseVersion . T.pack) <$> subdirs
notes <- liftIO $ ifM (doesFileExist notesPath) (Just <$> readFile notesPath) (pure Nothing) for_ failures $ \f -> $logWarn [i|Emver Parse Failure for EOS: #{f}|]
pure $ avr { appVersionMinCompanion = Just $ Version (1, 1, 0, 0), appVersionReleaseNotes = notes } let res = headMay . sortOn Down . filter (`satisfies` spec) $ successes
where sysExt = Extension (toS sysAppId) :: Extension "" maybe (sendResponseStatus status404 (NotFoundE [i|EOS version satisfying #{spec}|])) (pure . AppVersionRes) res
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)

16
src/Lib/Error.hs
View File

@@ -15,6 +15,7 @@ data S9Error =
PersistentE Text PersistentE Text
| AppMgrE Text ExitCode | AppMgrE Text ExitCode
| NotFoundE Text | NotFoundE Text
| InvalidParamsE Text Text
deriving (Show, Eq) deriving (Show, Eq)
instance Exception S9Error instance Exception S9Error
@@ -22,14 +23,16 @@ instance Exception S9Error
-- | Redact any sensitive data in this function -- | Redact any sensitive data in this function
toError :: S9Error -> Error toError :: S9Error -> Error
toError = \case toError = \case
PersistentE t -> Error DATABASE_ERROR t PersistentE t -> Error DATABASE_ERROR t
AppMgrE cmd code -> Error APPMGR_ERROR [i|"appmgr #{cmd}" exited with #{code}|] AppMgrE cmd code -> Error APPMGR_ERROR [i|"appmgr #{cmd}" exited with #{code}|]
NotFoundE e -> Error NOT_FOUND [i|#{e}|] NotFoundE e -> Error NOT_FOUND [i|#{e}|]
InvalidParamsE e m -> Error INVALID_PARAMS [i|Could not parse request parameters #{e}: #{m}|]
data ErrorCode = data ErrorCode =
DATABASE_ERROR DATABASE_ERROR
| APPMGR_ERROR | APPMGR_ERROR
| NOT_FOUND | NOT_FOUND
| INVALID_PARAMS
deriving (Eq, Show) deriving (Eq, Show)
instance ToJSON ErrorCode where instance ToJSON ErrorCode where
@@ -54,9 +57,10 @@ instance ToContent S9Error where
toStatus :: S9Error -> Status toStatus :: S9Error -> Status
toStatus = \case toStatus = \case
PersistentE _ -> status500 PersistentE _ -> status500
AppMgrE _ _ -> status500 AppMgrE _ _ -> status500
NotFoundE _ -> status404 NotFoundE _ -> status404
InvalidParamsE _ _ -> status400
handleS9ErrT :: MonadHandler m => S9ErrT m a -> m a 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 qualified Data.Conduit.List as CL
import Data.Conduit.Process.Typed import Data.Conduit.Process.Typed
import Lib.Error import Lib.Error
import Lib.Registry
import System.FilePath ( (</>) ) import System.FilePath ( (</>) )
import UnliftIO ( MonadUnliftIO import UnliftIO ( MonadUnliftIO
, catch , catch

69
src/Lib/PkgRepository.hs
View File

@@ -28,6 +28,9 @@ import Control.Monad.Reader.Has ( Has
) )
import Data.Aeson ( eitherDecodeFileStrict' ) import Data.Aeson ( eitherDecodeFileStrict' )
import qualified Data.Attoparsec.Text as Atto import qualified Data.Attoparsec.Text as Atto
import Data.ByteString ( readFile
, writeFile
)
import Data.String.Interpolate.IsString import Data.String.Interpolate.IsString
( i ) ( i )
import qualified Data.Text as T import qualified Data.Text as T
@@ -37,7 +40,9 @@ import Lib.Types.AppIndex ( PkgId(..)
, ServiceManifest(serviceManifestIcon) , ServiceManifest(serviceManifestIcon)
) )
import Lib.Types.Emver ( Version import Lib.Types.Emver ( Version
, VersionRange
, parseVersion , parseVersion
, satisfies
) )
import Startlude ( ($) import Startlude ( ($)
, (&&) , (&&)
@@ -46,11 +51,13 @@ import Startlude ( ($)
, (<>) , (<>)
, Bool(..) , Bool(..)
, ByteString , ByteString
, Down(Down)
, Either(Left, Right) , Either(Left, Right)
, Eq((==)) , Eq((==))
, Exception , Exception
, FilePath , FilePath
, IO , IO
, Integer
, Maybe(Just, Nothing) , Maybe(Just, Nothing)
, MonadIO(liftIO) , MonadIO(liftIO)
, MonadReader , MonadReader
@@ -59,10 +66,12 @@ import Startlude ( ($)
, find , find
, for_ , for_
, fromMaybe , fromMaybe
, headMay
, not , not
, partitionEithers , partitionEithers
, pure , pure
, show , show
, sortOn
, throwIO , throwIO
) )
import System.FSNotify ( Event(Added) import System.FSNotify ( Event(Added)
@@ -87,7 +96,8 @@ import UnliftIO ( MonadUnliftIO
) )
import UnliftIO ( tryPutMVar ) import UnliftIO ( tryPutMVar )
import UnliftIO.Concurrent ( forkIO ) import UnliftIO.Concurrent ( forkIO )
import UnliftIO.Directory ( listDirectory import UnliftIO.Directory ( getFileSize
, listDirectory
, removeFile , removeFile
, renameFile , renameFile
) )
@@ -116,6 +126,15 @@ getVersionsFor pkg = do
for_ failures $ \f -> $logWarn [i|Emver Parse Failure for #{pkg}: #{f}|] for_ failures $ \f -> $logWarn [i|Emver Parse Failure for #{pkg}: #{f}|]
pure successes 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 -- extract all package assets into their own respective files
extractPkg :: (MonadUnliftIO m, MonadReader r m, Has PkgRepo r, MonadLoggerIO m) => FilePath -> m () extractPkg :: (MonadUnliftIO m, MonadReader r m, Has PkgRepo r, MonadLoggerIO m) => FilePath -> m ()
extractPkg fp = (`onException` cleanup) $ do extractPkg fp = (`onException` cleanup) $ do
@@ -125,6 +144,7 @@ extractPkg fp = (`onException` cleanup) $ do
-- let s9pk = pkgRoot </> show pkg <.> "s9pk" -- let s9pk = pkgRoot </> show pkg <.> "s9pk"
manifestTask <- async $ liftIO . runResourceT $ AppMgr.sourceManifest appmgr fp $ sinkIt manifestTask <- async $ liftIO . runResourceT $ AppMgr.sourceManifest appmgr fp $ sinkIt
(pkgRoot </> "manifest.json") (pkgRoot </> "manifest.json")
pkgHashTask <- async $ AppMgr.getPackageHash appmgr fp
instructionsTask <- async $ liftIO . runResourceT $ AppMgr.sourceInstructions appmgr fp $ sinkIt instructionsTask <- async $ liftIO . runResourceT $ AppMgr.sourceInstructions appmgr fp $ sinkIt
(pkgRoot </> "instructions.md") (pkgRoot </> "instructions.md")
licenseTask <- async $ liftIO . runResourceT $ AppMgr.sourceLicense appmgr fp $ sinkIt (pkgRoot </> "license.md") licenseTask <- async $ liftIO . runResourceT $ AppMgr.sourceLicense appmgr fp $ sinkIt (pkgRoot </> "license.md")
@@ -139,6 +159,8 @@ extractPkg fp = (`onException` cleanup) $ do
wait iconTask wait iconTask
let iconDest = "icon" <.> T.unpack (fromMaybe "png" (serviceManifestIcon manifest)) let iconDest = "icon" <.> T.unpack (fromMaybe "png" (serviceManifestIcon manifest))
liftIO $ renameFile (pkgRoot </> "icon.tmp") (pkgRoot </> iconDest) liftIO $ renameFile (pkgRoot </> "icon.tmp") (pkgRoot </> iconDest)
hash <- wait pkgHashTask
liftIO $ writeFile (pkgRoot </> "hash.bin") hash
wait instructionsTask wait instructionsTask
wait licenseTask wait licenseTask
where where
@@ -167,28 +189,40 @@ watchPkgRepoRoot = do
Added path _ isDir -> not isDir && takeExtension path == ".s9pk" Added path _ isDir -> not isDir && takeExtension path == ".s9pk"
_ -> False _ -> 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 getManifest pkg version = do
root <- asks pkgRepoFileRoot root <- asks pkgRepoFileRoot
let manifestPath = root </> show pkg </> show version </> "manifest.json" 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 getInstructions pkg version = do
root <- asks pkgRepoFileRoot root <- asks pkgRepoFileRoot
let instructionsPath = root </> show pkg </> show version </> "instructions.md" 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 getLicense pkg version = do
root <- asks pkgRepoFileRoot root <- asks pkgRepoFileRoot
let licensePath = root </> show pkg </> show version </> "license.md" 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) getIcon :: (MonadResource m, MonadReader r m, Has PkgRepo r)
=> PkgId => PkgId
-> Version -> Version
-> m (ContentType, ConduitT () ByteString m ()) -> m (ContentType, Integer, ConduitT () ByteString m ())
getIcon pkg version = do getIcon pkg version = do
root <- asks pkgRepoFileRoot root <- asks pkgRepoFileRoot
let pkgRoot = root </> show pkg </> show version let pkgRoot = root </> show pkg </> show version
@@ -203,4 +237,21 @@ getIcon pkg version = do
".svg" -> typeSvg ".svg" -> typeSvg
".gif" -> typeGif ".gif" -> typeGif
_ -> typePlain _ -> 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 , exactly
, parseVersion , parseVersion
, parseRange , parseRange
) ) where
where
import Prelude import Control.Applicative ( Alternative((<|>))
, liftA2
)
import Data.Aeson
import qualified Data.Attoparsec.Text as Atto import qualified Data.Attoparsec.Text as Atto
import Data.Function import Data.Function
import Data.Functor ( (<&>) import Data.Functor ( ($>)
, ($>) , (<&>)
)
import Control.Applicative ( liftA2
, Alternative((<|>))
) )
import Data.String ( IsString(..) ) import Data.String ( IsString(..) )
import qualified Data.Text as T import qualified Data.Text as T
import Data.Aeson import Prelude
import Startlude ( Hashable ) import Startlude ( Hashable )
-- | AppVersion is the core representation of the SemverQuad type. -- | 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, Just _) -> Just b
_ -> Nothing _ -> 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 TemplateHaskell #-}
{-# LANGUAGE FlexibleContexts #-}
module Util.Shared where module Util.Shared where
@@ -8,33 +9,27 @@ import qualified Data.Text as T
import Network.HTTP.Types import Network.HTTP.Types
import Yesod.Core import Yesod.Core
import Data.Semigroup import Control.Monad.Reader.Has ( Has )
import Foundation import Foundation
import Lib.External.AppMgr import Lib.PkgRepository ( PkgRepo
import Lib.Registry , getHash
)
import Lib.Types.AppIndex ( PkgId )
import Lib.Types.Emver import Lib.Types.Emver
getVersionFromQuery :: KnownSymbol a => FilePath -> Extension a -> Handler (Maybe Version) getVersionSpecFromQuery :: Handler VersionRange
getVersionFromQuery rootDir ext = do getVersionSpecFromQuery = do
specString <- T.filter (not . isSpace) . fromMaybe "*" <$> lookupGetParam "spec" 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) Nothing -> sendResponseStatus status400 ("Invalid App Version Specification" :: Text)
Just t -> pure t Just t -> pure t
getBestVersion rootDir ext spec
getBestVersion :: (MonadIO m, KnownSymbol a, MonadLogger m) addPackageHeader :: (MonadUnliftIO m, MonadHandler m, MonadReader r m, Has PkgRepo r) => PkgId -> Version -> m ()
=> FilePath addPackageHeader pkg version = do
-> Extension a packageHash <- getHash pkg version
-> 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
addHeader "X-S9PK-HASH" $ decodeUtf8 packageHash 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