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

wip

Browse Source
This commit is contained in:
Keagan McClelland
2022-06-08 18:30:21 -06:00
parent bb0488f1dd
commit 8b0e856392
34 changed files with 1490 additions and 1262 deletions
Download Patch File Download Diff File Expand all files Collapse all files

4
.gitignore vendored
View File

@@ -35,4 +35,6 @@ start9-registry.prof
start9-registry.hp
start9-registry.pdf
start9-registry.aux
start9-registry.ps
start9-registry.ps
shell.nix
testdata/

2
Makefile
View File

@@ -1,2 +1,4 @@
all:
stack build --local-bin-path dist --copy-bins
profile:
stack build --local-bin-path dist --copy-bins --profile

20
config/routes
View File

@@ -3,16 +3,16 @@
/eos/v0/eos.img EosR GET -- get eos.img
-- PACKAGE API V0
/package/v0/info InfoR GET -- get all marketplace categories
/package/v0/index PackageListR GET -- filter marketplace services by various query params
/package/v0/latest VersionLatestR GET -- get latest version of apps in query param id
!/package/v0/#S9PK AppR GET -- get most recent appId at appversion spec, defaults to >=0.0.0 -- ?spec=<emver>
/package/v0/manifest/#PkgId AppManifestR GET -- get app manifest from appmgr -- ?spec=<emver>
/package/v0/release-notes/#PkgId ReleaseNotesR GET -- get release notes for all versions of a package
/package/v0/icon/#PkgId IconsR GET -- get icons - can specify version with ?spec=<emver>
/package/v0/license/#PkgId LicenseR GET -- get license - can specify version with ?spec=<emver>
/package/v0/instructions/#PkgId InstructionsR GET -- get instructions - can specify version with ?spec=<emver>
/package/v0/version/#PkgId PkgVersionR GET -- get most recent appId version
/package/#ApiVersion/info InfoR GET -- get all marketplace categories
/package/#ApiVersion/index PackageIndexR GET -- filter marketplace services by various query params
/package/#ApiVersion/latest VersionLatestR GET -- get latest version of apps in query param id
!/package/#ApiVersion/#S9PK AppR GET -- get most recent appId at appversion spec, defaults to >=0.0.0 -- ?spec=<emver>
/package/#ApiVersion/manifest/#PkgId AppManifestR GET -- get app manifest from appmgr -- ?spec=<emver>
/package/#ApiVersion/release-notes/#PkgId ReleaseNotesR GET -- get release notes for all versions of a package
/package/#ApiVersion/icon/#PkgId IconsR GET -- get icons - can specify version with ?spec=<emver>
/package/#ApiVersion/license/#PkgId LicenseR GET -- get license - can specify version with ?spec=<emver>
/package/#ApiVersion/instructions/#PkgId InstructionsR GET -- get instructions - can specify version with ?spec=<emver>
/package/#ApiVersion/version/#PkgId PkgVersionR GET -- get most recent appId version
-- SUPPORT API V0
/support/v0/error-logs ErrorLogsR POST

8
fourmolu.yaml Normal file
View File

@@ -0,0 +1,8 @@
indentation: 4
comma-style: leading
record-brace-space: false
indent-wheres: true
diff-friendly-import-export: true
respectful: true
haddock-style: single-line
newlines-between-decls: 2

9
package.yaml
View File

@@ -2,15 +2,10 @@ name: start9-registry
version: 0.2.1
default-extensions:
- FlexibleInstances
- GeneralizedNewtypeDeriving
- LambdaCase
- MultiWayIf
- NamedFieldPuns
- NoImplicitPrelude
- NumericUnderscores
- GHC2021
- LambdaCase
- OverloadedStrings
- StandaloneDeriving
dependencies:
- base >=4.12 && <5

13
src/Application.hs
View File

@@ -165,22 +165,11 @@ import Handler.Admin ( deleteCategoryR
, postPkgIndexR
, postPkgUploadR
)
import Handler.Apps ( getAppManifestR
, getAppR
)
import Handler.ErrorLogs ( postErrorLogsR )
import Handler.Icons ( getIconsR
, getInstructionsR
, getLicenseR
)
import Handler.Marketplace ( getEosR
, getEosVersionR
, getInfoR
, getPackageListR
, getReleaseNotesR
, getVersionLatestR
)
import Handler.Version ( getPkgVersionR )
import Handler.Package
import Lib.PkgRepository ( watchEosRepoRoot )
import Lib.Ssl ( doesSslNeedRenew
, renewSslCerts

336
src/Database/Marketplace.hs
View File

@@ -1,107 +1,127 @@
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Fuse on/on" #-}
module Database.Marketplace where
import Conduit ( ConduitT
, MonadResource
, MonadUnliftIO
, awaitForever
, leftover
, yield
)
import Control.Monad.Loops ( unfoldM )
import Data.Conduit ( await )
import Database.Esqueleto.Experimental
( (%)
, (&&.)
, (++.)
, (:&)(..)
, (==.)
, (^.)
, asc
, desc
, from
, groupBy
, ilike
, in_
, innerJoin
, on
, orderBy
, select
, selectSource
, table
, val
, valList
, where_
, (||.)
)
import qualified Database.Persist as P
import Database.Persist.Postgresql ( ConnectionPool
, Entity(entityKey, entityVal)
, PersistEntity(Key)
, SqlBackend
, runSqlPool
)
import Handler.Types.Marketplace ( PackageDependencyMetadata(..) )
import Lib.Types.AppIndex ( PkgId )
import Lib.Types.Emver ( Version )
import Model ( Category
, EntityField
( CategoryId
, CategoryName
, PkgCategoryCategoryId
, PkgCategoryPkgId
, PkgDependencyDepId
, PkgDependencyPkgId
, PkgDependencyPkgVersion
, PkgRecordId
, VersionRecordDescLong
, VersionRecordDescShort
, VersionRecordNumber
, VersionRecordPkgId
, VersionRecordTitle
, VersionRecordUpdatedAt
)
, Key(PkgRecordKey, unPkgRecordKey)
, PkgCategory
, PkgDependency
, PkgRecord
, VersionRecord(versionRecordNumber, versionRecordPkgId)
)
import Startlude ( ($)
, ($>)
, (.)
, (<$>)
, Applicative(pure)
, Down(Down)
, Eq((==))
, Functor(fmap)
, Maybe(..)
, Monad
, MonadIO
, ReaderT
, Text
, headMay
, lift
, snd
, sortOn
)
import Conduit (
ConduitT,
MonadResource,
MonadUnliftIO,
awaitForever,
leftover,
yield,
)
import Control.Monad.Loops (unfoldM)
import Data.Conduit (await)
import Database.Esqueleto.Experimental (
asc,
desc,
from,
groupBy,
ilike,
in_,
innerJoin,
on,
orderBy,
select,
selectSource,
table,
val,
valList,
where_,
(%),
(&&.),
(++.),
(:&) (..),
(==.),
(^.),
(||.),
)
import Database.Persist qualified as P
import Database.Persist.Postgresql (
ConnectionPool,
Entity (entityKey, entityVal),
PersistEntity (Key),
SqlBackend,
runSqlPool,
)
import Lib.Types.AppIndex (PkgId)
import Lib.Types.Emver (Version)
import Model (
Category,
EntityField (
CategoryId,
CategoryName,
PkgCategoryCategoryId,
PkgCategoryPkgId,
PkgDependencyDepId,
PkgDependencyPkgId,
PkgDependencyPkgVersion,
PkgRecordId,
VersionRecordDescLong,
VersionRecordDescShort,
VersionRecordNumber,
VersionRecordPkgId,
VersionRecordTitle,
VersionRecordUpdatedAt
),
Key (PkgRecordKey, unPkgRecordKey),
PkgCategory,
PkgDependency,
PkgRecord,
VersionRecord (versionRecordNumber, versionRecordPkgId),
)
import Startlude (
Applicative (pure),
Down (Down),
Eq ((==)),
Functor (fmap),
Maybe (..),
Monad,
MonadIO,
ReaderT,
Show,
Text,
headMay,
lift,
snd,
sortOn,
($),
($>),
(.),
(<$>),
)
type CategoryTitle = Text
searchServices :: (MonadResource m, MonadIO m)
=> Maybe CategoryTitle
-> Text
-> ConduitT () (Entity VersionRecord) (ReaderT SqlBackend m) ()
data PackageMetadata = PackageMetadata
{ packageMetadataPkgId :: !PkgId
, packageMetadataPkgVersionRecords :: ![Entity VersionRecord]
, packageMetadataPkgCategories :: ![Entity Category]
, packageMetadataPkgVersion :: !Version
}
deriving (Eq, Show)
data PackageDependencyMetadata = PackageDependencyMetadata
{ packageDependencyMetadataPkgDependencyRecord :: !(Entity PkgDependency)
, packageDependencyMetadataDepPkgRecord :: !(Entity PkgRecord)
, packageDependencyMetadataDepVersions :: ![Entity VersionRecord]
}
deriving (Eq, Show)
searchServices ::
(MonadResource m, MonadIO m) =>
Maybe Text ->
Text ->
ConduitT () (Entity VersionRecord) (ReaderT SqlBackend m) ()
searchServices Nothing query = selectSource $ do
service <- from $ table @VersionRecord
where_
( (service ^. VersionRecordDescShort `ilike` (%) ++. val query ++. (%))
||. (service ^. VersionRecordDescLong `ilike` (%) ++. val query ++. (%))
||. (service ^. VersionRecordTitle `ilike` (%) ++. val query ++. (%))
( (service ^. VersionRecordDescShort `ilike` (%) ++. val query ++. (%))
||. (service ^. VersionRecordDescLong `ilike` (%) ++. val query ++. (%))
||. (service ^. VersionRecordTitle `ilike` (%) ++. val query ++. (%))
)
groupBy (service ^. VersionRecordPkgId, service ^. VersionRecordNumber)
orderBy
@@ -111,27 +131,28 @@ searchServices Nothing query = selectSource $ do
]
pure service
searchServices (Just category) query = selectSource $ do
services <- from
(do
(service :& _ :& cat) <-
from
$ table @VersionRecord
`innerJoin` table @PkgCategory
`on` (\(s :& sc) -> sc ^. PkgCategoryPkgId ==. s ^. VersionRecordPkgId)
`innerJoin` table @Category
`on` (\(_ :& sc :& cat) -> sc ^. PkgCategoryCategoryId ==. cat ^. CategoryId)
-- if there is a cateogry, only search in category
-- weight title, short, long (bitcoin should equal Bitcoin Core)
where_
$ cat
^. CategoryName
==. val category
&&. ( (service ^. VersionRecordDescShort `ilike` (%) ++. val query ++. (%))
||. (service ^. VersionRecordDescLong `ilike` (%) ++. val query ++. (%))
||. (service ^. VersionRecordTitle `ilike` (%) ++. val query ++. (%))
)
pure service
)
services <-
from
( do
(service :& _ :& cat) <-
from $
table @VersionRecord
`innerJoin` table @PkgCategory
`on` (\(s :& sc) -> sc ^. PkgCategoryPkgId ==. s ^. VersionRecordPkgId)
`innerJoin` table @Category
`on` (\(_ :& sc :& cat) -> sc ^. PkgCategoryCategoryId ==. cat ^. CategoryId)
-- if there is a cateogry, only search in category
-- weight title, short, long (bitcoin should equal Bitcoin Core)
where_ $
cat
^. CategoryName
==. val category
&&. ( (service ^. VersionRecordDescShort `ilike` (%) ++. val query ++. (%))
||. (service ^. VersionRecordDescLong `ilike` (%) ++. val query ++. (%))
||. (service ^. VersionRecordTitle `ilike` (%) ++. val query ++. (%))
)
pure service
)
groupBy (services ^. VersionRecordPkgId, services ^. VersionRecordNumber)
orderBy
[ asc (services ^. VersionRecordPkgId)
@@ -140,48 +161,56 @@ searchServices (Just category) query = selectSource $ do
]
pure services
getPkgData :: (MonadResource m, MonadIO m) => [PkgId] -> ConduitT () (Entity VersionRecord) (ReaderT SqlBackend m) ()
getPkgData pkgs = selectSource $ do
pkgData <- from $ table @VersionRecord
where_ (pkgData ^. VersionRecordPkgId `in_` valList (PkgRecordKey <$> pkgs))
pure pkgData
getPkgDependencyData :: MonadIO m
=> Key PkgRecord
-> Version
-> ReaderT SqlBackend m [(Entity PkgDependency, Entity PkgRecord)]
getPkgDependencyData ::
MonadIO m =>
Key PkgRecord ->
Version ->
ReaderT SqlBackend m [(Entity PkgDependency, Entity PkgRecord)]
getPkgDependencyData pkgId pkgVersion = select $ do
from
(do
( do
(pkgDepRecord :& depPkgRecord) <-
from
$ table @PkgDependency
`innerJoin` table @PkgRecord
`on` (\(pdr :& dpr) -> dpr ^. PkgRecordId ==. pdr ^. PkgDependencyDepId)
from $
table @PkgDependency
`innerJoin` table @PkgRecord
`on` (\(pdr :& dpr) -> dpr ^. PkgRecordId ==. pdr ^. PkgDependencyDepId)
where_ (pkgDepRecord ^. PkgDependencyPkgId ==. val pkgId)
where_ (pkgDepRecord ^. PkgDependencyPkgVersion ==. val pkgVersion)
pure (pkgDepRecord, depPkgRecord)
)
zipCategories :: MonadUnliftIO m
=> ConduitT
(PkgId, [Entity VersionRecord])
(PkgId, [Entity VersionRecord], [Entity Category])
(ReaderT SqlBackend m)
()
zipCategories ::
MonadUnliftIO m =>
ConduitT
(PkgId, [Entity VersionRecord])
(PkgId, [Entity VersionRecord], [Entity Category])
(ReaderT SqlBackend m)
()
zipCategories = awaitForever $ \(pkg, vers) -> do
raw <- lift $ select $ do
(sc :& cat) <-
from
$ table @PkgCategory
`innerJoin` table @Category
`on` (\(sc :& cat) -> sc ^. PkgCategoryCategoryId ==. cat ^. CategoryId)
where_ (sc ^. PkgCategoryPkgId ==. val (PkgRecordKey pkg))
pure cat
raw <- lift $
select $ do
(sc :& cat) <-
from $
table @PkgCategory
`innerJoin` table @Category
`on` (\(sc :& cat) -> sc ^. PkgCategoryCategoryId ==. cat ^. CategoryId)
where_ (sc ^. PkgCategoryPkgId ==. val (PkgRecordKey pkg))
pure cat
yield (pkg, vers, raw)
collateVersions :: MonadUnliftIO m
=> ConduitT (Entity VersionRecord) (PkgId, [Entity VersionRecord]) (ReaderT SqlBackend m) ()
collateVersions ::
MonadUnliftIO m =>
ConduitT (Entity VersionRecord) (PkgId, [Entity VersionRecord]) (ReaderT SqlBackend m) ()
collateVersions = awaitForever $ \v0 -> do
let pkg = unPkgRecordKey . versionRecordPkgId $ entityVal v0
let pull = do
@@ -194,32 +223,39 @@ collateVersions = awaitForever $ \v0 -> do
ls <- unfoldM pull
yield (pkg, v0 : ls)
zipDependencyVersions :: (Monad m, MonadIO m)
=> (Entity PkgDependency, Entity PkgRecord)
-> ReaderT SqlBackend m PackageDependencyMetadata
zipDependencyVersions ::
(Monad m, MonadIO m) =>
(Entity PkgDependency, Entity PkgRecord) ->
ReaderT SqlBackend m PackageDependencyMetadata
zipDependencyVersions (pkgDepRecord, depRecord) = do
let pkgDbId = entityKey depRecord
depVers <- select $ do
v <- from $ table @VersionRecord
where_ $ v ^. VersionRecordPkgId ==. val pkgDbId
pure v
pure $ PackageDependencyMetadata { packageDependencyMetadataPkgDependencyRecord = pkgDepRecord
, packageDependencyMetadataDepPkgRecord = depRecord
, packageDependencyMetadataDepVersions = depVers
}
pure $
PackageDependencyMetadata
{ packageDependencyMetadataPkgDependencyRecord = pkgDepRecord
, packageDependencyMetadataDepPkgRecord = depRecord
, packageDependencyMetadataDepVersions = depVers
}
fetchAllAppVersions :: MonadUnliftIO m => ConnectionPool -> PkgId -> m [VersionRecord]
fetchAllAppVersions appConnPool appId = do
entityAppVersions <- runSqlPool (P.selectList [VersionRecordPkgId P.==. PkgRecordKey appId] []) appConnPool
pure $ entityVal <$> entityAppVersions
fetchLatestApp :: MonadIO m => PkgId -> ReaderT SqlBackend m (Maybe (P.Entity PkgRecord, P.Entity VersionRecord))
fetchLatestApp appId = fmap headMay . sortResults . select $ do
(service :& version) <-
from
$ table @PkgRecord
`innerJoin` table @VersionRecord
`on` (\(service :& version) -> service ^. PkgRecordId ==. version ^. VersionRecordPkgId)
from $
table @PkgRecord
`innerJoin` table @VersionRecord
`on` (\(service :& version) -> service ^. PkgRecordId ==. version ^. VersionRecordPkgId)
where_ (service ^. PkgRecordId ==. val (PkgRecordKey appId))
pure (service, version)
where sortResults = fmap $ sortOn (Down . versionRecordNumber . entityVal . snd)
where
sortResults = fmap $ sortOn (Down . versionRecordNumber . entityVal . snd)

395
src/Foundation.hs
View File

@@ -1,184 +1,203 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Foundation where
import Startlude ( ($)
, (.)
, (<$>)
, (<&>)
, (<**>)
, (=<<)
, Applicative(pure)
, Bool(False)
, Eq((==))
, IO
, MVar
, Maybe(..)
, Monad(return)
, Monoid(mempty)
, Semigroup((<>))
, String
, Text
, ThreadId
, Word64
, decodeUtf8
, drop
, encodeUtf8
, flip
, fst
, isJust
, otherwise
, putMVar
, show
, when
, (||)
)
import Startlude (
Applicative (pure),
Bool (False),
Eq ((==)),
IO,
MVar,
Maybe (..),
Monad (return),
Monoid (mempty),
Semigroup ((<>)),
String,
Text,
ThreadId,
Word64,
decodeUtf8,
drop,
encodeUtf8,
flip,
fst,
isJust,
otherwise,
putMVar,
show,
when,
($),
(.),
(<$>),
(<&>),
(<**>),
(=<<),
(||),
)
import Control.Monad.Logger ( Loc
, LogSource
, LogStr
, ToLogStr(toLogStr)
, fromLogStr
)
import Database.Persist.Sql ( ConnectionPool
, LogFunc
, PersistStoreRead(get)
, SqlBackend
, SqlPersistT
, runSqlPool
)
import Lib.Registry ( S9PK )
import Yesod.Core ( AuthResult(Authorized, Unauthorized)
, LogLevel(..)
, MonadHandler(liftHandler)
, RenderMessage(..)
, RenderRoute(Route, renderRoute)
, RouteAttrs(routeAttrs)
, SessionBackend
, ToTypedContent
, Yesod
( isAuthorized
, makeLogger
, makeSessionBackend
, maximumContentLengthIO
, messageLoggerSource
, shouldLogIO
, yesodMiddleware
)
, defaultYesodMiddleware
, getYesod
, getsYesod
, mkYesodData
, parseRoutesFile
)
import Yesod.Core.Types ( HandlerData(handlerEnv)
, Logger(loggerDate)
, RunHandlerEnv(rheChild, rheSite)
, loggerPutStr
)
import qualified Yesod.Core.Unsafe as Unsafe
import Control.Monad.Logger (
Loc,
LogSource,
LogStr,
ToLogStr (toLogStr),
fromLogStr,
)
import Database.Persist.Sql (
ConnectionPool,
LogFunc,
PersistStoreRead (get),
SqlBackend,
SqlPersistT,
runSqlPool,
)
import Lib.Registry (S9PK)
import Yesod.Core (
AuthResult (Authorized, Unauthorized),
LogLevel (..),
MonadHandler (liftHandler),
RenderMessage (..),
RenderRoute (Route, renderRoute),
RouteAttrs (routeAttrs),
SessionBackend,
ToTypedContent,
Yesod (
isAuthorized,
makeLogger,
makeSessionBackend,
maximumContentLengthIO,
messageLoggerSource,
shouldLogIO,
yesodMiddleware
),
defaultYesodMiddleware,
getYesod,
getsYesod,
mkYesodData,
parseRoutesFile,
)
import Yesod.Core.Types (
HandlerData (handlerEnv),
Logger (loggerDate),
RunHandlerEnv (rheChild, rheSite),
loggerPutStr,
)
import Yesod.Core.Unsafe qualified as Unsafe
import Control.Monad.Logger.Extras (wrapSGRCode)
import Control.Monad.Reader.Has (Has (extract, update))
import Crypto.Hash (
SHA256 (SHA256),
hashWith,
)
import Data.Set (member)
import Data.String.Interpolate.IsString (
i,
)
import Data.Text qualified as T
import Handler.Types.Api (ApiVersion (..))
import Language.Haskell.TH (Loc (..))
import Lib.PkgRepository (
EosRepo,
PkgRepo,
)
import Lib.Types.AppIndex (PkgId)
import Model (
Admin (..),
Key (AdminKey),
)
import Settings (AppSettings (appShouldLogAll))
import System.Console.ANSI.Codes (
Color (..),
ColorIntensity (..),
ConsoleLayer (Foreground),
SGR (SetColor),
)
import Yesod (
FormMessage,
defaultFormMessage,
)
import Yesod.Auth (
AuthEntity,
Creds (credsIdent),
YesodAuth (
AuthId,
authPlugins,
getAuthId,
loginDest,
logoutDest,
maybeAuthId
),
YesodAuthPersist (getAuthEntity),
)
import Yesod.Auth.Http.Basic (
defaultAuthSettings,
defaultMaybeBasicAuthId,
)
import Yesod.Persist.Core (
DBRunner,
YesodPersist (..),
YesodPersistRunner (..),
defaultGetDBRunner,
)
import Control.Monad.Logger.Extras ( wrapSGRCode )
import Control.Monad.Reader.Has ( Has(extract, update) )
import Crypto.Hash ( SHA256(SHA256)
, hashWith
)
import Data.Set ( member )
import Data.String.Interpolate.IsString
( i )
import qualified Data.Text as T
import Language.Haskell.TH ( Loc(..) )
import Lib.PkgRepository ( EosRepo
, PkgRepo
)
import Lib.Types.AppIndex ( PkgId )
import Model ( Admin(..)
, Key(AdminKey)
)
import Settings ( AppSettings(appShouldLogAll) )
import System.Console.ANSI.Codes ( Color(..)
, ColorIntensity(..)
, ConsoleLayer(Foreground)
, SGR(SetColor)
)
import Yesod ( FormMessage
, defaultFormMessage
)
import Yesod.Auth ( AuthEntity
, Creds(credsIdent)
, YesodAuth
( AuthId
, authPlugins
, getAuthId
, loginDest
, logoutDest
, maybeAuthId
)
, YesodAuthPersist(getAuthEntity)
)
import Yesod.Auth.Http.Basic ( defaultAuthSettings
, defaultMaybeBasicAuthId
)
import Yesod.Persist.Core ( DBRunner
, YesodPersist(..)
, YesodPersistRunner(..)
, defaultGetDBRunner
)
-- | The foundation datatype for your application. This can be a good place to
-- keep settings and values requiring initialization before your application
-- starts running, such as database connections. Every handler will have
-- access to the data present here.
data RegistryCtx = RegistryCtx
{ appSettings :: AppSettings
, appLogger :: Logger
{ appSettings :: AppSettings
, appLogger :: Logger
, appWebServerThreadId :: MVar (ThreadId, ThreadId)
, appShouldRestartWeb :: MVar Bool
, appConnPool :: ConnectionPool
, appStopFsNotifyEos :: IO Bool
, appShouldRestartWeb :: MVar Bool
, appConnPool :: ConnectionPool
, appStopFsNotifyEos :: IO Bool
}
instance Has PkgRepo RegistryCtx where
extract = transitiveExtract @AppSettings
update = transitiveUpdate @AppSettings
update = transitiveUpdate @AppSettings
instance Has a r => Has a (HandlerData r r) 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 }
rhe = (handlerEnv r){rheSite = ctx, rheChild = ctx}
in r{handlerEnv = rhe}
instance Has AppSettings RegistryCtx where
extract = appSettings
update f ctx = ctx { appSettings = f (appSettings ctx) }
update f ctx = ctx{appSettings = f (appSettings ctx)}
instance Has EosRepo RegistryCtx where
extract = transitiveExtract @AppSettings
update = transitiveUpdate @AppSettings
update = transitiveUpdate @AppSettings
{-# INLINE transitiveExtract #-}
transitiveExtract :: forall b a c . (Has a b, Has b c) => c -> a
transitiveExtract :: forall b a c. (Has a b, Has b c) => c -> a
transitiveExtract = extract @a . extract @b
{-# INLINE transitiveUpdate #-}
transitiveUpdate :: forall b a c . (Has a b, Has b c) => (a -> a) -> (c -> c)
transitiveUpdate :: forall b a c. (Has a b, Has b c) => (a -> a) -> (c -> c)
transitiveUpdate f = update (update @a @b f)
setWebProcessThreadId :: (ThreadId, ThreadId) -> RegistryCtx -> IO ()
setWebProcessThreadId tid@(!_, !_) a = putMVar (appWebServerThreadId a) tid
-- This is where we define all of the routes in our application. For a full
-- explanation of the syntax, please see:
-- http://www.yesodweb.com/book/routing-and-handlers
@@ -193,68 +212,73 @@ setWebProcessThreadId tid@(!_, !_) a = putMVar (appWebServerThreadId a) tid
-- type Handler = HandlerT RegistryCtx IO
mkYesodData "RegistryCtx" $(parseRoutesFile "config/routes")
-- Please see the documentation for the Yesod typeclass. There are a number
-- of settings which can be configured by overriding methods here.
instance Yesod RegistryCtx where
-- Store session data on the client in encrypted cookies,
-- default session idle timeout is 120 minutes
-- Store session data on the client in encrypted cookies,
-- default session idle timeout is 120 minutes
makeSessionBackend :: RegistryCtx -> IO (Maybe SessionBackend)
makeSessionBackend _ = pure Nothing
-- Yesod Middleware allows you to run code before and after each handler function.
-- The defaultYesodMiddleware adds the response header "Vary: Accept, Accept-Language" and performs authorization checks.
-- Some users may also want to add the defaultCsrfMiddleware, which:
-- a) Sets a cookie with a CSRF token in it.
-- b) Validates that incoming write requests include that token in either a header or POST parameter.
-- To add it, chain it together with the defaultMiddleware: yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware
-- For details, see the CSRF documentation in the Yesod.Core.Handler module of the yesod-core package.
-- Yesod Middleware allows you to run code before and after each handler function.
-- The defaultYesodMiddleware adds the response header "Vary: Accept, Accept-Language" and performs authorization checks.
-- Some users may also want to add the defaultCsrfMiddleware, which:
-- a) Sets a cookie with a CSRF token in it.
-- b) Validates that incoming write requests include that token in either a header or POST parameter.
-- To add it, chain it together with the defaultMiddleware: yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware
-- For details, see the CSRF documentation in the Yesod.Core.Handler module of the yesod-core package.
yesodMiddleware :: ToTypedContent res => Handler res -> Handler res
yesodMiddleware = defaultYesodMiddleware
-- What messages should be logged. The following includes all messages when
-- in development, and warnings and errors in production.
-- What messages should be logged. The following includes all messages when
-- in development, and warnings and errors in production.
shouldLogIO :: RegistryCtx -> LogSource -> LogLevel -> IO Bool
shouldLogIO app _source level =
return $ appShouldLogAll (appSettings app) || level == LevelInfo || level == LevelWarn || level == LevelError
makeLogger :: RegistryCtx -> IO Logger
makeLogger = return . appLogger
messageLoggerSource :: RegistryCtx -> Logger -> Loc -> LogSource -> LogLevel -> LogStr -> IO ()
messageLoggerSource ctx logger = \loc src lvl str -> do
shouldLog <- shouldLogIO ctx src lvl
when shouldLog $ do
date <- loggerDate logger
let
formatted =
let formatted =
toLogStr date
<> ( toLogStr
. wrapSGRCode [SetColor Foreground Vivid (colorFor lvl)]
$ fromLogStr
( " ["
<> renderLvl lvl
<> (if T.null src then mempty else "#" <> toLogStr src)
<> "] "
<> str
)
. wrapSGRCode [SetColor Foreground Vivid (colorFor lvl)]
$ fromLogStr
( " ["
<> renderLvl lvl
<> (if T.null src then mempty else "#" <> toLogStr src)
<> "] "
<> str
)
)
<> toLogStr
(wrapSGRCode [SetColor Foreground Dull White]
[i| @ #{loc_filename loc}:#{fst $ loc_start loc}\n|]
)
( wrapSGRCode
[SetColor Foreground Dull White]
[i| @ #{loc_filename loc}:#{fst $ loc_start loc}\n|]
)
loggerPutStr logger formatted
where
renderLvl lvl = case lvl of
LevelOther t -> toLogStr t
_ -> toLogStr @String $ drop 5 $ show lvl
_ -> toLogStr @String $ drop 5 $ show lvl
colorFor = \case
LevelDebug -> Green
LevelInfo -> Blue
LevelWarn -> Yellow
LevelError -> Red
LevelDebug -> Green
LevelInfo -> Blue
LevelWarn -> Yellow
LevelError -> Red
LevelOther _ -> White
isAuthorized :: Route RegistryCtx -> Bool -> Handler AuthResult
isAuthorized route _
| "admin" `member` routeAttrs route = do
@@ -262,9 +286,11 @@ instance Yesod RegistryCtx where
pure $ if hasAuthId then Authorized else Unauthorized "This feature is for admins only"
| otherwise = pure Authorized
maximumContentLengthIO :: RegistryCtx -> Maybe (Route RegistryCtx) -> IO (Maybe Word64)
maximumContentLengthIO _ (Just PkgUploadR) = pure Nothing
maximumContentLengthIO _ _ = pure $ Just 2097152 -- the original default
maximumContentLengthIO _ _ = pure $ Just 2097152 -- the original default
-- How to run database actions.
instance YesodPersist RegistryCtx where
@@ -272,37 +298,40 @@ instance YesodPersist RegistryCtx where
runDB :: SqlPersistT Handler a -> Handler a
runDB action = runSqlPool action . appConnPool =<< getYesod
instance YesodPersistRunner RegistryCtx where
getDBRunner :: Handler (DBRunner RegistryCtx, Handler ())
getDBRunner = defaultGetDBRunner appConnPool
instance RenderMessage RegistryCtx FormMessage where
renderMessage _ _ = defaultFormMessage
instance YesodAuth RegistryCtx where
type AuthId RegistryCtx = Text
getAuthId = pure . Just . credsIdent
getAuthId = pure . Just . credsIdent
maybeAuthId = do
pool <- getsYesod appConnPool
let checkCreds k s = flip runSqlPool pool $ do
let passHash = hashWith SHA256 . encodeUtf8 . ("start9_admin:" <>) $ decodeUtf8 s
get (AdminKey $ decodeUtf8 k) <&> \case
Nothing -> False
Just Admin { adminPassHash } -> adminPassHash == passHash
Nothing -> False
Just Admin{adminPassHash} -> adminPassHash == passHash
defaultMaybeBasicAuthId checkCreds defaultAuthSettings
loginDest _ = PackageListR
logoutDest _ = PackageListR
loginDest _ = PackageIndexR V1
logoutDest _ = PackageIndexR V1
authPlugins _ = []
instance YesodAuthPersist RegistryCtx where
type AuthEntity RegistryCtx = Admin
getAuthEntity = liftHandler . runDB . get . AdminKey
unsafeHandler :: RegistryCtx -> Handler a -> IO a
unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger
-- Note: Some functionality previously present in the scaffolding has been
-- moved to documentation in the Wiki. Following are some hopefully helpful
-- links:

6
src/Handler/Admin.hs
View File

@@ -43,6 +43,9 @@ import Database.Queries ( upsertPackageVersion )
import Foundation ( Handler
, RegistryCtx(..)
)
import Handler.Util ( orThrow
, sendResponseText
)
import Lib.PkgRepository ( PkgRepo(PkgRepo, pkgRepoFileRoot)
, extractPkg
, getManifestLocation
@@ -110,9 +113,6 @@ import UnliftIO.Directory ( createDirectoryIfMissing
, renameDirectory
, renameFile
)
import Util.Shared ( orThrow
, sendResponseText
)
import Yesod ( ToJSON(..)
, delete
, getsYesod

150
src/Handler/Apps.hs
View File

@@ -1,98 +1,107 @@
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
module Handler.Apps where
import Startlude ( ($)
, (.)
, Applicative(pure)
, FilePath
, Maybe(..)
, Monad((>>=))
, Show
, String
, show
, void
)
import Startlude (
Applicative (pure),
FilePath,
Maybe (..),
Monad ((>>=)),
Show,
String,
show,
void,
($),
(.),
)
import Control.Monad.Logger ( logError )
import qualified Data.Text as T
import qualified GHC.Show ( Show(..) )
import Network.HTTP.Types ( status404 )
import System.FilePath ( (<.>)
, takeBaseName
)
import Yesod.Core ( Content(ContentFile)
, TypedContent
, addHeader
, notFound
, respond
, respondSource
, sendChunkBS
, sendResponseStatus
, typeJson
, typeOctet
)
import Yesod.Persist.Core ( YesodPersist(runDB) )
import Control.Monad.Logger (logError)
import Data.Text qualified as T
import GHC.Show qualified (Show (..))
import Network.HTTP.Types (status404)
import System.FilePath (
takeBaseName,
(<.>),
)
import Yesod.Core (
Content (ContentFile),
TypedContent,
addHeader,
notFound,
respond,
respondSource,
sendChunkBS,
sendResponseStatus,
typeJson,
typeOctet,
)
import Yesod.Persist.Core (YesodPersist (runDB))
import Conduit (
awaitForever,
(.|),
)
import Data.String.Interpolate.IsString (
i,
)
import Database.Queries (
createMetric,
fetchApp,
fetchAppVersion,
)
import Foundation (Handler)
import Handler.Util (addPackageHeader, getVersionSpecFromQuery, orThrow, versionPriorityFromQueryIsMin)
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)
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 )
import Util.Shared ( addPackageHeader
, getVersionSpecFromQuery
, orThrow
, versionPriorityFromQueryIsMin
)
data FileExtension = FileExtension !FilePath !(Maybe String)
instance Show FileExtension where
show (FileExtension f Nothing ) = f
show (FileExtension f Nothing) = f
show (FileExtension f (Just e)) = f <.> e
getAppManifestR :: PkgId -> Handler TypedContent
getAppManifestR pkg = do
versionSpec <- getVersionSpecFromQuery
preferMin <- versionPriorityFromQueryIsMin
version <- getBestVersion pkg versionSpec preferMin
`orThrow` sendResponseStatus status404 (NotFoundE [i|#{pkg} satisfying #{versionSpec}|])
preferMin <- versionPriorityFromQueryIsMin
version <-
getBestVersion pkg versionSpec preferMin
`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 :: S9PK -> Handler TypedContent
getAppR file = do
let pkg = PkgId . T.pack $ takeBaseName (show file)
versionSpec <- getVersionSpecFromQuery
preferMin <- versionPriorityFromQueryIsMin
version <- getBestVersion pkg versionSpec preferMin
`orThrow` sendResponseStatus status404 (NotFoundE [i|#{pkg} satisfying #{versionSpec}|])
preferMin <- versionPriorityFromQueryIsMin
version <-
getBestVersion pkg versionSpec preferMin
`orThrow` sendResponseStatus status404 (NotFoundE [i|#{pkg} satisfying #{versionSpec}|])
addPackageHeader pkg version
void $ recordMetrics pkg version
pkgPath <- getPackage pkg version >>= \case
Nothing -> sendResponseStatus status404 (NotFoundE [i|#{pkg}@#{version}|])
Just a -> pure a
pkgPath <-
getPackage pkg version >>= \case
Nothing -> sendResponseStatus status404 (NotFoundE [i|#{pkg}@#{version}|])
Just a -> pure a
respond typeOctet $ ContentFile pkgPath Nothing
@@ -110,4 +119,3 @@ recordMetrics pkg appVersion = do
$logError [i|#{pkg}@#{appVersion} not found in database|]
notFound
Just _ -> runDB $ createMetric pkg appVersion

1
src/Handler/Eos/V0/EosImg.hs Normal file
View File

@@ -0,0 +1 @@
module Handler.Eos.V0.EosImg where

25
src/Handler/Eos/V0/Latest.hs Normal file
View File

@@ -0,0 +1,25 @@
{-# LANGUAGE RecordWildCards #-}
module Handler.Eos.V0.Latest where
import Data.Aeson (ToJSON (toJSON), object, (.=))
import Handler.Package.V0.ReleaseNotes (ReleaseNotes)
import Lib.Types.Emver (Version)
import Orphans.Emver ()
import Startlude (Eq, Generic, Show, Text, (.))
import Yesod (ToContent (toContent), ToTypedContent (..))
data EosRes = EosRes
{ eosResVersion :: !Version
, eosResHeadline :: !Text
, eosResReleaseNotes :: !ReleaseNotes
}
deriving (Eq, Show, Generic)
instance ToJSON EosRes where
toJSON EosRes{..} =
object ["version" .= eosResVersion, "headline" .= eosResHeadline, "release-notes" .= eosResReleaseNotes]
instance ToContent EosRes where
toContent = toContent . toJSON
instance ToTypedContent EosRes where
toTypedContent = toTypedContent . toJSON

76
src/Handler/Icons.hs
View File

@@ -1,80 +1,18 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
module Handler.Icons where
import Startlude ( ($)
, Eq
, Generic
, Read
, Show
, show
)
import Data.Aeson (FromJSON, ToJSON)
import Startlude (Eq, Generic, Read, Show)
import Data.Conduit ( (.|)
, awaitForever
)
import Data.String.Interpolate.IsString
( i )
import Foundation ( Handler )
import Lib.Error ( S9Error(NotFoundE) )
import Lib.PkgRepository ( getBestVersion
, getIcon
, getInstructions
, getLicense
)
import Lib.Types.AppIndex ( PkgId )
import Network.HTTP.Types ( status400 )
import Util.Shared ( getVersionSpecFromQuery
, orThrow
, versionPriorityFromQueryIsMin
)
import Yesod.Core ( FromJSON
, ToJSON
, TypedContent
, addHeader
, respondSource
, sendChunkBS
, sendResponseStatus
, typePlain
)
data IconType = PNG | JPG | JPEG | SVG
deriving (Eq, Show, Generic, Read)
instance ToJSON IconType
instance FromJSON IconType
getIconsR :: PkgId -> Handler TypedContent
getIconsR pkg = do
spec <- getVersionSpecFromQuery
preferMin <- versionPriorityFromQueryIsMin
version <- getBestVersion pkg spec preferMin
`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 pkg = do
spec <- getVersionSpecFromQuery
preferMin <- versionPriorityFromQueryIsMin
version <- getBestVersion pkg spec preferMin
`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 pkg = do
spec <- getVersionSpecFromQuery
preferMin <- versionPriorityFromQueryIsMin
version <- getBestVersion pkg spec preferMin
`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

627
src/Handler/Marketplace.hs
View File

@@ -6,255 +6,265 @@
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Redundant <$>" #-}
module Handler.Marketplace where
import Startlude ( ($)
, (&&&)
, (.)
, (<$>)
, (<&>)
, Applicative((*>), pure)
, Bool(True)
, ByteString
, Down(Down)
, Either(Left, Right)
, FilePath
, Foldable(foldMap)
, Functor(fmap)
, Int
, Maybe(..)
, Monad((>>=))
, MonadIO
, MonadReader
, Monoid(mappend)
, Num((*), (-))
, Ord((<))
, ReaderT(runReaderT)
, Text
, Traversable(traverse)
, catMaybes
, const
, decodeUtf8
, encodeUtf8
, filter
, flip
, for_
, fromMaybe
, fst
, head
, headMay
, id
, maybe
, partitionEithers
, readMaybe
, show
, snd
, void
)
import Startlude (
Applicative (pure, (*>)),
Bool (True),
ByteString,
Down (Down),
Either (Left, Right),
FilePath,
Foldable (foldMap),
Functor (fmap),
Int,
Maybe (..),
Monad ((>>=)),
MonadIO,
MonadReader,
Monoid (mappend),
Num ((*), (-)),
Ord ((<)),
ReaderT (runReaderT),
Text,
Traversable (traverse),
catMaybes,
const,
decodeUtf8,
encodeUtf8,
filter,
flip,
for_,
fromMaybe,
fst,
head,
headMay,
id,
maybe,
partitionEithers,
readMaybe,
show,
snd,
void,
($),
(&&&),
(.),
(<$>),
(<&>),
)
import Conduit ( (.|)
, dropC
, runConduit
, sinkList
, takeC
)
import Control.Monad.Logger ( MonadLogger
, logWarn
)
import Control.Monad.Reader.Has ( Has
, ask
)
import Crypto.Hash ( SHA256 )
import Crypto.Hash.Conduit ( hashFile )
import Data.Aeson ( decode
, eitherDecode
, eitherDecodeStrict
)
import qualified Data.Attoparsec.Text as Atto
import Conduit (
dropC,
runConduit,
sinkList,
takeC,
(.|),
)
import Control.Monad.Logger (
MonadLogger,
logWarn,
)
import Control.Monad.Reader.Has (
Has,
ask,
)
import Crypto.Hash (SHA256)
import Crypto.Hash.Conduit (hashFile)
import Data.Aeson (
decode,
eitherDecode,
eitherDecodeStrict,
)
import Data.Attoparsec.Text qualified as Atto
import Data.Attoparsec.Text (
Parser,
parseOnly,
)
import Data.ByteArray.Encoding (
Base (..),
convertToBase,
)
import Data.ByteString.Base64 (encodeBase64)
import Data.ByteString.Lazy qualified as LBS
import Data.Conduit.List qualified as CL
import Data.HashMap.Strict qualified as HM
import Data.List (
lookup,
sortOn,
)
import Data.String.Interpolate.IsString (
i,
)
import Data.Text qualified as T
import Data.Text.Lazy qualified as TL
import Data.Text.Lazy.Builder qualified as TB
import Database.Esqueleto.Experimental (
Entity (entityKey, entityVal),
SqlBackend,
asc,
desc,
from,
orderBy,
select,
table,
(^.),
)
import Database.Marketplace (
collateVersions,
fetchAllAppVersions,
fetchLatestApp,
getPkgData,
getPkgDependencyData,
searchServices,
zipCategories,
zipDependencyVersions,
)
import Database.Persist (
PersistUniqueRead (getBy),
insertUnique,
)
import Foundation (
Handler,
RegistryCtx (appConnPool, appSettings),
Route (InstructionsR, LicenseR),
)
import Handler.Util (getVersionSpecFromQuery)
import Lib.Error (S9Error (..))
import Lib.PkgRepository (
PkgRepo,
getIcon,
getManifest,
)
import Lib.Types.AppIndex (PkgId)
import Lib.Types.Emver (
Version,
VersionRange,
parseRange,
parseVersion,
satisfies,
)
import Model (
Category (..),
EntityField (..),
EosHash (EosHash, eosHashHash),
Key (PkgRecordKey, unPkgRecordKey),
OsVersion (..),
PkgRecord (..),
Unique (UniqueVersion),
VersionRecord (..),
)
import Network.HTTP.Types (
status400,
status404,
)
import Protolude.Unsafe (unsafeFromJust)
import Settings (AppSettings (marketplaceName, resourcesDir))
import System.FilePath ((</>))
import UnliftIO.Async (mapConcurrently)
import UnliftIO.Directory (listDirectory)
import Util.Shared (
filterDependencyBestVersion,
filterDependencyOsCompatible,
filterLatestVersionFromSpec,
filterPkgOsCompatible,
)
import Yesod.Core (
Content (ContentFile),
MonadHandler,
MonadResource,
RenderRoute (renderRoute),
TypedContent,
YesodRequest (..),
addHeader,
getRequest,
getYesod,
getsYesod,
lookupGetParam,
respond,
sendResponseStatus,
typeOctet,
)
import Yesod.Core.Types (JSONResponse (..))
import Yesod.Persist (YesodDB)
import Yesod.Persist.Core (YesodPersist (runDB))
import Data.Attoparsec.Text ( Parser
, parseOnly
)
import Data.ByteArray.Encoding ( Base(..)
, convertToBase
)
import Data.ByteString.Base64 ( encodeBase64 )
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Conduit.List as CL
import qualified Data.HashMap.Strict as HM
import Data.List ( lookup
, sortOn
)
import Data.String.Interpolate.IsString
( i )
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TB
import Database.Esqueleto.Experimental
( Entity(entityKey, entityVal)
, SqlBackend
, (^.)
, asc
, desc
, from
, orderBy
, select
, table
)
import Database.Marketplace ( collateVersions
, fetchAllAppVersions
, fetchLatestApp
, getPkgData
, getPkgDependencyData
, searchServices
, zipCategories
, zipDependencyVersions
)
import Database.Persist ( PersistUniqueRead(getBy)
, insertUnique
)
import Foundation ( Handler
, RegistryCtx(appConnPool, appSettings)
, Route(InstructionsR, LicenseR)
)
import Handler.Types.Marketplace ( CategoryTitle
, DependencyRes(..)
, EosRes(..)
, InfoRes(InfoRes)
, OrderArrangement(DESC)
, PackageListDefaults
( PackageListDefaults
, packageListCategory
, packageListOrder
, packageListPageLimit
, packageListPageNumber
, packageListQuery
)
, PackageListRes(..)
, PackageMetadata(..)
, PackageReq(packageReqId, packageReqVersion)
, PackageRes(..)
, ReleaseNotes(ReleaseNotes)
, VersionLatestRes(..)
)
import Lib.Error ( S9Error(..) )
import Lib.PkgRepository ( PkgRepo
, getIcon
, getManifest
)
import Lib.Types.AppIndex ( PkgId )
import Lib.Types.Emver ( Version
, VersionRange
, parseRange
, parseVersion
, satisfies
)
import Model ( Category(..)
, EntityField(..)
, EosHash(EosHash, eosHashHash)
, Key(PkgRecordKey, unPkgRecordKey)
, OsVersion(..)
, PkgRecord(..)
, Unique(UniqueVersion)
, VersionRecord(..)
)
import Network.HTTP.Types ( status400
, status404
)
import Protolude.Unsafe ( unsafeFromJust )
import Settings ( AppSettings(marketplaceName, resourcesDir) )
import System.FilePath ( (</>) )
import UnliftIO.Async ( mapConcurrently )
import UnliftIO.Directory ( listDirectory )
import Util.Shared ( filterDependencyBestVersion
, filterDependencyOsCompatible
, filterLatestVersionFromSpec
, filterPkgOsCompatible
, getVersionSpecFromQuery
)
import Yesod.Core ( Content(ContentFile)
, MonadHandler
, MonadResource
, RenderRoute(renderRoute)
, TypedContent
, YesodRequest(..)
, addHeader
, getRequest
, getYesod
, getsYesod
, lookupGetParam
, respond
, sendResponseStatus
, typeOctet
)
import Yesod.Core.Types ( JSONResponse(..) )
import Yesod.Persist ( YesodDB )
import Yesod.Persist.Core ( YesodPersist(runDB) )
queryParamAs :: MonadHandler m => Text -> Parser a -> m (Maybe a)
queryParamAs k p = lookupGetParam k >>= \case
Nothing -> pure Nothing
Just x -> case parseOnly p x of
Left e ->
sendResponseStatus @_ @Text status400 [i|Invalid Request! The query parameter '#{k}' failed to parse: #{e}|]
Right a -> pure (Just a)
queryParamAs k p =
lookupGetParam k >>= \case
Nothing -> pure Nothing
Just x -> case parseOnly p x of
Left e ->
sendResponseStatus @_ @Text status400 [i|Invalid Request! The query parameter '#{k}' failed to parse: #{e}|]
Right a -> pure (Just a)
getInfoR :: Handler (JSONResponse InfoRes)
getInfoR = do
name <- getsYesod $ marketplaceName . appSettings
allCategories <- runDB $ select $ do
cats <- from $ table @Category
orderBy [asc (cats ^. CategoryPriority)]
pure cats
name <- getsYesod $ marketplaceName . appSettings
allCategories <- runDB $
select $ do
cats <- from $ table @Category
orderBy [asc (cats ^. CategoryPriority)]
pure cats
pure $ JSONResponse $ InfoRes name $ categoryName . entityVal <$> allCategories
getEosVersionR :: Handler (JSONResponse (Maybe EosRes))
getEosVersionR = do
eosVersion <- queryParamAs "eos-version" parseVersion
allEosVersions <- runDB $ select $ do
vers <- from $ table @OsVersion
orderBy [desc (vers ^. OsVersionCreatedAt)]
pure vers
let osV = entityVal <$> allEosVersions
eosVersion <- queryParamAs "eos-version" parseVersion
allEosVersions <- runDB $
select $ do
vers <- from $ table @OsVersion
orderBy [desc (vers ^. OsVersionCreatedAt)]
pure vers
let osV = entityVal <$> allEosVersions
let mLatest = head osV
let mappedVersions =
ReleaseNotes
$ HM.fromList
$ sortOn (Down . fst)
$ filter (maybe (const True) (<) eosVersion . fst)
$ (\v -> (osVersionNumber v, osVersionReleaseNotes v))
<$> osV
pure . JSONResponse $ mLatest <&> \latest -> EosRes { eosResVersion = osVersionNumber latest
, eosResHeadline = osVersionHeadline latest
, eosResReleaseNotes = mappedVersions
}
ReleaseNotes $
HM.fromList $
sortOn (Down . fst) $
filter (maybe (const True) (<) eosVersion . fst) $
(\v -> (osVersionNumber v, osVersionReleaseNotes v))
<$> osV
pure . JSONResponse $
mLatest <&> \latest ->
EosRes
{ eosResVersion = osVersionNumber latest
, eosResHeadline = osVersionHeadline latest
, eosResReleaseNotes = mappedVersions
}
getReleaseNotesR :: PkgId -> Handler ReleaseNotes
getReleaseNotesR pkg = do
appConnPool <- appConnPool <$> getYesod
appConnPool <- appConnPool <$> getYesod
versionRecords <- runDB $ fetchAllAppVersions appConnPool pkg
pure $ constructReleaseNotesApiRes versionRecords
where
constructReleaseNotesApiRes :: [VersionRecord] -> ReleaseNotes
constructReleaseNotesApiRes vers = do
ReleaseNotes
$ HM.fromList
$ sortOn (Down . fst)
$ (versionRecordNumber &&& versionRecordReleaseNotes)
<$> vers
ReleaseNotes $
HM.fromList $
sortOn (Down . fst) $
(versionRecordNumber &&& versionRecordReleaseNotes)
<$> vers
getEosR :: Handler TypedContent
getEosR = do
spec <- getVersionSpecFromQuery
root <- getsYesod $ (</> "eos") . resourcesDir . appSettings
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 mVersion = headMay . sortOn Down . filter (`satisfies` spec) $ successes
case mVersion of
Nothing -> sendResponseStatus status404 (NotFoundE [i|EOS version satisfying #{spec}|])
Nothing -> sendResponseStatus status404 (NotFoundE [i|EOS version satisfying #{spec}|])
Just version -> do
let imgPath = root </> show version </> "eos.img"
h <- runDB $ retrieveHash version imgPath
@@ -265,187 +275,32 @@ getEosR = do
retrieveHash v fp = do
mHash <- getBy (UniqueVersion v)
case mHash of
Just h -> pure . eosHashHash . entityVal $ h
Just h -> pure . eosHashHash . entityVal $ h
Nothing -> do
h <- hashFile @_ @SHA256 fp
let t = decodeUtf8 $ convertToBase Base16 h
void $ insertUnique (EosHash v t) -- lazily populate
pure t
-- TODO refactor with conduit
getVersionLatestR :: Handler VersionLatestRes
getVersionLatestR = do
getParameters <- reqGetParams <$> getRequest
case lookup "ids" getParameters of
Nothing -> sendResponseStatus status400 (InvalidParamsE "get:ids" "<MISSING>")
Nothing -> sendResponseStatus status400 (InvalidParamsE "get:ids" "<MISSING>")
Just packages -> case eitherDecode $ LBS.fromStrict $ encodeUtf8 packages of
Left _ -> sendResponseStatus status400 (InvalidParamsE "get:ids" packages)
Left _ -> sendResponseStatus status400 (InvalidParamsE "get:ids" packages)
Right p -> do
let packageList = (, Nothing) <$> p
let packageList = (,Nothing) <$> p
found <- runDB $ traverse fetchLatestApp $ fst <$> packageList
pure
$ VersionLatestRes
$ HM.union
( HM.fromList
$ (\v ->
(unPkgRecordKey . entityKey $ fst v, Just $ versionRecordNumber $ entityVal $ snd v)
)
<$> catMaybes found
)
$ HM.fromList packageList
getPackageListR :: Handler PackageListRes
getPackageListR = do
osPredicate <- getOsVersionQuery <&> \case
Nothing -> const True
Just v -> flip satisfies v
pkgIds <- getPkgIdsQuery
filteredPackages <- case pkgIds of
Nothing -> do
-- query for all
category <- getCategoryQuery
page <- getPageQuery
limit' <- getLimitQuery
query <- T.strip . fromMaybe (packageListQuery defaults) <$> lookupGetParam "query"
runDB
$ runConduit
$ searchServices category query
.| collateVersions
.| zipCategories
-- empty list since there are no requested packages in this case
.| filterLatestVersionFromSpec []
.| filterPkgOsCompatible osPredicate
-- pages start at 1 for some reason. TODO: make pages start at 0
.| (dropC (limit' * (page - 1)) *> takeC limit')
.| sinkList
Just packages' -> do
-- for each item in list get best available from version range
let vMap = (packageReqId &&& packageReqVersion) <$> packages'
runDB
-- TODO could probably be better with sequenceConduits
. runConduit
$ getPkgData (packageReqId <$> packages')
.| collateVersions
.| zipCategories
.| filterLatestVersionFromSpec vMap
.| filterPkgOsCompatible osPredicate
.| sinkList
-- NOTE: if a package's dependencies do not meet the system requirements, it is currently omitted from the list
pkgsWithDependencies <- runDB $ mapConcurrently (getPackageDependencies osPredicate) filteredPackages
PackageListRes <$> mapConcurrently constructPackageListApiRes pkgsWithDependencies
where
defaults = PackageListDefaults { packageListOrder = DESC
, packageListPageLimit = 20
, packageListPageNumber = 1
, packageListCategory = Nothing
, packageListQuery = ""
}
getPkgIdsQuery :: Handler (Maybe [PackageReq])
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 Int
getPageQuery = lookupGetParam "page" >>= \case
Nothing -> pure $ packageListPageNumber 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 Int
getLimitQuery = lookupGetParam "per-page" >>= \case
Nothing -> pure $ packageListPageLimit 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
getOsVersionQuery :: Handler (Maybe VersionRange)
getOsVersionQuery = lookupGetParam "eos-version-compat" >>= \case
Nothing -> pure Nothing
Just osv -> case Atto.parseOnly parseRange osv of
Left _ -> do
let e = InvalidParamsE "get:eos-version-compat" osv
$logWarn (show e)
sendResponseStatus status400 e
Right v -> pure $ Just v
getPackageDependencies :: (MonadIO m, MonadLogger m)
=> (Version -> Bool)
-> PackageMetadata
-> ReaderT
SqlBackend
m
( Key PkgRecord
, [Category]
, [Version]
, Version
, [(Key PkgRecord, Text, Version)]
)
getPackageDependencies osPredicate PackageMetadata { packageMetadataPkgId = pkg, packageMetadataPkgVersionRecords = pkgVersions, packageMetadataPkgCategories = pkgCategories, packageMetadataPkgVersion = pkgVersion }
= do
let pkgId = PkgRecordKey pkg
let pkgVersions' = versionRecordNumber . entityVal <$> pkgVersions
let pkgCategories' = entityVal <$> pkgCategories
pkgDepInfo <- getPkgDependencyData pkgId pkgVersion
pkgDepInfoWithVersions <- traverse zipDependencyVersions pkgDepInfo
let compatiblePkgDepInfo = fmap (filterDependencyOsCompatible osPredicate) pkgDepInfoWithVersions
res <- catMaybes <$> traverse filterDependencyBestVersion compatiblePkgDepInfo
pure (pkgId, pkgCategories', pkgVersions', pkgVersion, res)
constructPackageListApiRes :: (MonadResource m, MonadReader r m, Has AppSettings r, Has PkgRepo r)
=> ( Key PkgRecord
, [Category]
, [Version]
, Version
, [(Key PkgRecord, Text, Version)]
)
-> m PackageRes
constructPackageListApiRes (pkgKey, pkgCategories, pkgVersions, pkgVersion, dependencies) = do
settings <- ask @_ @_ @AppSettings
let pkgId = unPkgRecordKey pkgKey
manifest <- flip runReaderT settings $ (snd <$> getManifest pkgId pkgVersion) >>= \bs ->
runConduit $ bs .| CL.foldMap LBS.fromStrict
icon <- loadIcon pkgId pkgVersion
deps <- constructDependenciesApiRes dependencies
pure $ PackageRes { packageResIcon = encodeBase64 icon -- pass through raw JSON Value, we have checked its correct parsing above
, packageResManifest = unsafeFromJust . decode $ manifest
, packageResCategories = categoryName <$> pkgCategories
, packageResInstructions = basicRender $ InstructionsR pkgId
, packageResLicense = basicRender $ LicenseR pkgId
, packageResVersions = pkgVersions
, packageResDependencies = HM.fromList deps
}
constructDependenciesApiRes :: (MonadResource m, MonadReader r m, Has PkgRepo r)
=> [(Key PkgRecord, Text, Version)]
-> m [(PkgId, DependencyRes)]
constructDependenciesApiRes deps = traverse
(\(depKey, depTitle, depVersion) -> do
let depId = unPkgRecordKey depKey
icon <- loadIcon depId depVersion
pure (depId, DependencyRes { dependencyResTitle = depTitle, dependencyResIcon = encodeBase64 icon })
)
deps
loadIcon :: (MonadResource m, MonadReader r m, Has PkgRepo r) => PkgId -> Version -> m ByteString
loadIcon pkg version = do
(_, _, src) <- getIcon pkg version
runConduit $ src .| CL.foldMap id
basicRender :: RenderRoute a => Route a -> Text
basicRender = TL.toStrict . TB.toLazyText . foldMap (mappend (TB.singleton '/') . TB.fromText) . fst . renderRoute
pure $
VersionLatestRes $
HM.union
( HM.fromList $
( \v ->
(unPkgRecordKey . entityKey $ fst v, Just $ versionRecordNumber $ entityVal $ snd v)
)
<$> catMaybes found
)
$ HM.fromList packageList

55
src/Handler/Package.hs Normal file
View File

@@ -0,0 +1,55 @@
module Handler.Package where
import Foundation (Handler)
import Handler.Package.V0.Index (PackageListRes)
import Handler.Package.V0.Info (InfoRes)
import Handler.Package.V0.Latest (VersionLatestRes)
import Handler.Package.V0.ReleaseNotes (ReleaseNotes)
import Handler.Types.Api (ApiVersion)
import Handler.Types.Status (AppVersionRes)
import Lib.Registry (S9PK)
import Lib.Types.AppIndex (PkgId)
import Yesod.Core.Types (
JSONResponse,
TypedContent,
)
getInfoR :: ApiVersion -> Handler (JSONResponse InfoRes)
getInfoR = _
getPackageListR :: ApiVersion -> Handler PackageListRes
getPackageListR = _
getVersionLatestR :: ApiVersion -> Handler VersionLatestRes
getVersionLatestR = _
getAppR :: ApiVersion -> S9PK -> Handler TypedContent
getAppR = _
getAppManifestR :: ApiVersion -> PkgId -> Handler TypedContent
getAppManifestR = _
getReleaseNotesR :: ApiVersion -> PkgId -> Handler ReleaseNotes
getReleaseNotesR = _
getIconsR :: ApiVersion -> PkgId -> Handler TypedContent
getIconsR = _
getLicenseR :: ApiVersion -> PkgId -> Handler TypedContent
getLicenseR = _
getInstructionsR :: ApiVersion -> PkgId -> Handler TypedContent
getInstructionsR = _
getPkgVersionR :: ApiVersion -> PkgId -> Handler AppVersionRes
getPkgVersionR = _

32
src/Handler/Package/V0/Icon.hs Normal file
View File

@@ -0,0 +1,32 @@
{-# LANGUAGE QuasiQuotes #-}
module Handler.Package.V0.Icon where
import Conduit (awaitForever, (.|))
import Data.String.Interpolate.IsString (
i,
)
import Foundation (Handler)
import Handler.Util (
getVersionSpecFromQuery,
orThrow,
versionPriorityFromQueryIsMin,
)
import Lib.Error (S9Error (..))
import Lib.PkgRepository (getBestVersion, getIcon)
import Lib.Types.AppIndex (PkgId)
import Network.HTTP.Types (status400)
import Startlude (show, ($))
import Yesod (TypedContent, addHeader, respondSource, sendChunkBS, sendResponseStatus)
getIconsR :: PkgId -> Handler TypedContent
getIconsR pkg = do
spec <- getVersionSpecFromQuery
preferMin <- versionPriorityFromQueryIsMin
version <-
getBestVersion pkg spec preferMin
`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

278
src/Handler/Package/V0/Index.hs Normal file
View File

@@ -0,0 +1,278 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
module Handler.Package.V0.Index where
import Conduit (runConduit, (.|))
import Control.Monad.Reader.Has (Functor (fmap), Has, Monad ((>>=)), MonadReader, ReaderT (runReaderT), ask)
import Data.Aeson (FromJSON (..), ToJSON (..), Value, decode, object, withObject, (.:), (.=))
import Data.Attoparsec.Text qualified as Atto
import Data.ByteString.Base64 (encodeBase64)
import Data.ByteString.Lazy qualified as LBS
import Data.Conduit.List qualified as CL
import Data.HashMap.Internal.Strict (HashMap)
import Data.HashMap.Strict qualified as HM
import Data.Text qualified as T
import Database.Marketplace (PackageMetadata (..), collateVersions, getPkgDependencyData, searchServices, zipDependencyVersions)
import Database.Persist (Entity (..), Key)
import Database.Persist.Sql (SqlBackend)
import Foundation (Handler, Route (InstructionsR, LicenseR))
import Lib.Error (S9Error (..))
import Lib.PkgRepository (PkgRepo, getIcon, getManifest)
import Lib.Types.AppIndex (PkgId)
import Lib.Types.Emver (Version, VersionRange, parseRange, satisfies)
import Model (Category (..), Key (..), PkgRecord (..), VersionRecord (..))
import Settings (AppSettings)
import Startlude (Bool (..), ByteString, Either (..), Eq, Generic, Int, Maybe (..), MonadIO, Read, Show, Text, Traversable (traverse), catMaybes, const, flip, fromMaybe, id, pure, snd, ($), (.), (<$>), (<&>))
import Yesod (MonadLogger, MonadResource, ToContent (..), ToTypedContent (..), YesodPersist (runDB), lookupGetParam)
import Yesod.Core (logWarn)
data PackageReq = PackageReq
{ packageReqId :: !PkgId
, packageReqVersion :: !VersionRange
}
deriving (Show)
instance FromJSON PackageReq where
parseJSON = withObject "package version" $ \o -> do
packageReqId <- o .: "id"
packageReqVersion <- o .: "version"
pure PackageReq{..}
data PackageRes = PackageRes
{ packageResIcon :: !Text
, packageResManifest :: !Value -- PackageManifest
, packageResCategories :: ![Text]
, packageResInstructions :: !Text
, packageResLicense :: !Text
, packageResVersions :: ![Version]
, packageResDependencies :: !(HashMap PkgId DependencyRes)
}
deriving (Show, Generic)
instance ToJSON PackageRes where
toJSON PackageRes{..} =
object
[ "icon" .= packageResIcon
, "license" .= packageResLicense
, "instructions" .= packageResInstructions
, "manifest" .= packageResManifest
, "categories" .= packageResCategories
, "versions" .= packageResVersions
, "dependency-metadata" .= packageResDependencies
]
instance FromJSON PackageRes where
parseJSON = withObject "PackageRes" $ \o -> do
packageResIcon <- o .: "icon"
packageResLicense <- o .: "license"
packageResInstructions <- o .: "instructions"
packageResManifest <- o .: "manifest"
packageResCategories <- o .: "categories"
packageResVersions <- o .: "versions"
packageResDependencies <- o .: "dependency-metadata"
pure PackageRes{..}
newtype PackageListRes = PackageListRes [PackageRes]
deriving (Generic)
instance ToJSON PackageListRes
instance ToContent PackageListRes where
toContent = toContent . toJSON
instance ToTypedContent PackageListRes where
toTypedContent = toTypedContent . toJSON
data DependencyRes = DependencyRes
{ dependencyResTitle :: !Text
, dependencyResIcon :: !Text
}
deriving (Eq, Show)
instance ToJSON DependencyRes where
toJSON DependencyRes{..} = object ["icon" .= dependencyResIcon, "title" .= dependencyResTitle]
instance FromJSON DependencyRes where
parseJSON = withObject "DependencyRes" $ \o -> do
dependencyResIcon <- o .: "icon"
dependencyResTitle <- o .: "title"
pure DependencyRes{..}
data PackageListDefaults = PackageListDefaults
{ packageListOrder :: !OrderArrangement
, packageListPageLimit :: !Int -- the number of items per page
, packageListPageNumber :: !Int -- the page you are on
, packageListCategory :: !(Maybe Text)
, packageListQuery :: !Text
}
deriving (Eq, Show, Read)
data OrderArrangement = ASC | DESC
deriving (Eq, Show, Read)
getPackageListR :: Handler PackageListRes
getPackageListR = do
osPredicate <-
getOsVersionQuery <&> \case
Nothing -> const True
Just v -> flip satisfies v
pkgIds <- getPkgIdsQuery
filteredPackages <- case pkgIds of
Nothing -> do
-- query for all
category <- getCategoryQuery
page <- getPageQuery
limit' <- getLimitQuery
query <- T.strip . fromMaybe (packageListQuery defaults) <$> lookupGetParam "query"
runDB $
runConduit $
searchServices category query
.| collateVersions
.| zipCategories
-- empty list since there are no requested packages in this case
.| filterLatestVersionFromSpec []
.| filterPkgOsCompatible osPredicate
-- pages start at 1 for some reason. TODO: make pages start at 0
.| (dropC (limit' * (page - 1)) *> takeC limit')
.| sinkList
Just packages' -> do
-- for each item in list get best available from version range
let vMap = (packageReqId &&& packageReqVersion) <$> packages'
runDB
-- TODO could probably be better with sequenceConduits
. runConduit
$ getPkgData (packageReqId <$> packages')
.| collateVersions
.| zipCategories
.| filterLatestVersionFromSpec vMap
.| filterPkgOsCompatible osPredicate
.| sinkList
-- NOTE: if a package's dependencies do not meet the system requirements, it is currently omitted from the list
pkgsWithDependencies <- runDB $ mapConcurrently (getPackageDependencies osPredicate) filteredPackages
PackageListRes <$> mapConcurrently constructPackageListApiRes pkgsWithDependencies
where
defaults =
PackageListDefaults
{ packageListOrder = DESC
, packageListPageLimit = 20
, packageListPageNumber = 1
, packageListCategory = Nothing
, packageListQuery = ""
}
getPkgIdsQuery :: Handler (Maybe [PackageReq])
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 Text)
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 Int
getPageQuery =
lookupGetParam "page" >>= \case
Nothing -> pure $ packageListPageNumber 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 Int
getLimitQuery =
lookupGetParam "per-page" >>= \case
Nothing -> pure $ packageListPageLimit 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
getOsVersionQuery :: Handler (Maybe VersionRange)
getOsVersionQuery =
lookupGetParam "eos-version-compat" >>= \case
Nothing -> pure Nothing
Just osv -> case Atto.parseOnly parseRange osv of
Left _ ->
do
let e = InvalidParamsE "get:eos-version-compat" osv
$logWarn (show e) sendResponseStatus status400 e
Right v -> pure $ Just v
getPackageDependencies ::
(MonadIO m, MonadLogger m) =>
(Version -> Bool) ->
PackageMetadata ->
ReaderT
SqlBackend
m
( Key PkgRecord
, [Category]
, [Version]
, Version
, [(Key PkgRecord, Text, Version)]
)
getPackageDependencies osPredicate PackageMetadata{packageMetadataPkgId = pkg, packageMetadataPkgVersionRecords = pkgVersions, packageMetadataPkgCategories = pkgCategories, packageMetadataPkgVersion = pkgVersion} =
do
let pkgId = PkgRecordKey pkg
let pkgVersions' = versionRecordNumber . entityVal <$> pkgVersions
let pkgCategories' = entityVal <$> pkgCategories
pkgDepInfo <- getPkgDependencyData pkgId pkgVersion
pkgDepInfoWithVersions <- traverse zipDependencyVersions pkgDepInfo
let compatiblePkgDepInfo = fmap (filterDependencyOsCompatible osPredicate) pkgDepInfoWithVersions
res <- catMaybes <$> traverse filterDependencyBestVersion compatiblePkgDepInfo
pure (pkgId, pkgCategories', pkgVersions', pkgVersion, res)
constructPackageListApiRes ::
(MonadResource m, MonadReader r m, Has AppSettings r, Has PkgRepo r) =>
( Key PkgRecord
, [Category]
, [Version]
, Version
, [(Key PkgRecord, Text, Version)]
) ->
m PackageRes
constructPackageListApiRes (pkgKey, pkgCategories, pkgVersions, pkgVersion, dependencies) = do
settings <- ask @_ @_ @AppSettings
let pkgId = unPkgRecordKey pkgKey
manifest <-
flip runReaderT settings $
(snd <$> getManifest pkgId pkgVersion) >>= \bs ->
runConduit $ bs .| CL.foldMap LBS.fromStrict
icon <- loadIcon pkgId pkgVersion
deps <- constructDependenciesApiRes dependencies
pure $
PackageRes
{ packageResIcon = encodeBase64 icon -- pass through raw JSON Value, we have checked its correct parsing above
, packageResManifest = unsafeFromJust . decode $ manifest
, packageResCategories = categoryName <$> pkgCategories
, packageResInstructions = basicRender $ InstructionsR _ pkgId
, packageResLicense = basicRender $ LicenseR _ pkgId
, packageResVersions = pkgVersions
, packageResDependencies = HM.fromList deps
}
constructDependenciesApiRes ::
(MonadResource m, MonadReader r m, Has PkgRepo r) =>
[(Key PkgRecord, Text, Version)] ->
m [(PkgId, DependencyRes)]
constructDependenciesApiRes deps =
traverse
( \(depKey, depTitle, depVersion) -> do
let depId = unPkgRecordKey depKey
icon <- loadIcon depId depVersion
pure (depId, DependencyRes{dependencyResTitle = depTitle, dependencyResIcon = encodeBase64 icon})
)
deps
loadIcon :: (MonadResource m, MonadReader r m, Has PkgRepo r) => PkgId -> Version -> m ByteString
loadIcon pkg version = do
(_, _, src) <- getIcon pkg version
runConduit $ src .| CL.foldMap id

17
src/Handler/Package/V0/Info.hs Normal file
View File

@@ -0,0 +1,17 @@
module Handler.Package.V0.Info where
import Data.Aeson (ToJSON (..))
import Startlude (Generic, Show, Text, (.))
import Yesod (ToContent (..), ToTypedContent (..))
data InfoRes = InfoRes
{ name :: !Text
, categories :: ![Text]
}
deriving (Show, Generic)
instance ToJSON InfoRes
instance ToContent InfoRes where
toContent = toContent . toJSON
instance ToTypedContent InfoRes where
toTypedContent = toTypedContent . toJSON

26
src/Handler/Package/V0/Instructions.hs Normal file
View File

@@ -0,0 +1,26 @@
{-# LANGUAGE QuasiQuotes #-}
module Handler.Package.V0.Instructions where
import Conduit (awaitForever, (.|))
import Data.String.Interpolate.IsString (i)
import Foundation (Handler)
import Handler.Util (getVersionSpecFromQuery, orThrow, versionPriorityFromQueryIsMin)
import Lib.Error (S9Error (..))
import Lib.PkgRepository (getBestVersion, getInstructions)
import Lib.Types.AppIndex (PkgId)
import Network.HTTP.Types (status400)
import Startlude (show, ($))
import Yesod (TypedContent, addHeader, respondSource, sendChunkBS, sendResponseStatus, typePlain)
getInstructionsR :: PkgId -> Handler TypedContent
getInstructionsR pkg = do
spec <- getVersionSpecFromQuery
preferMin <- versionPriorityFromQueryIsMin
version <-
getBestVersion pkg spec preferMin
`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

17
src/Handler/Package/V0/Latest.hs Normal file
View File

@@ -0,0 +1,17 @@
module Handler.Package.V0.Latest where
import Data.Aeson (ToJSON (..))
import Data.HashMap.Strict (HashMap)
import Lib.Types.AppIndex (PkgId)
import Lib.Types.Emver (Version)
import Startlude (Generic, Maybe, Show, (.))
import Yesod (ToContent (..), ToTypedContent (..))
newtype VersionLatestRes = VersionLatestRes (HashMap PkgId (Maybe Version))
deriving (Show, Generic)
instance ToJSON VersionLatestRes
instance ToContent VersionLatestRes where
toContent = toContent . toJSON
instance ToTypedContent VersionLatestRes where
toTypedContent = toTypedContent . toJSON

21
src/Handler/Package/V0/License.hs Normal file
View File

@@ -0,0 +1,21 @@
{-# LANGUAGE QuasiQuotes #-}
module Handler.Package.V0.License where
import Data.String.Interpolate.IsString (i)
import Foundation (Handler)
import Handler.Util (getVersionSpecFromQuery)
import Lib.Types.AppIndex (PkgId)
import Yesod (TypedContent)
getLicenseR :: PkgId -> Handler TypedContent
getLicenseR pkg = do
spec <- getVersionSpecFromQuery
preferMin <- versionPriorityFromQueryIsMin
version <-
getBestVersion pkg spec preferMin
`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

1
src/Handler/Package/V0/Manifest.hs Normal file
View File

@@ -0,0 +1 @@
module Handler.Package.V0.Manifest where

20
src/Handler/Package/V0/ReleaseNotes.hs Normal file
View File

@@ -0,0 +1,20 @@
{-# LANGUAGE RecordWildCards #-}
module Handler.Package.V0.ReleaseNotes where
import Data.Aeson (ToJSON (..), Value (..), object, (.=))
import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as HM
import Lib.Types.Emver (Version)
import Startlude (Eq, Show, Text, (.))
import Yesod (ToContent (..), ToTypedContent (..))
newtype ReleaseNotes = ReleaseNotes {unReleaseNotes :: HashMap Version Text}
deriving (Eq, Show)
instance ToJSON ReleaseNotes where
toJSON ReleaseNotes{..} = toJSON unReleaseNotes
instance ToContent ReleaseNotes where
toContent = toContent . toJSON
instance ToTypedContent ReleaseNotes where
toTypedContent = toTypedContent . toJSON

1
src/Handler/Package/V0/S9PK.hs Normal file
View File

@@ -0,0 +1 @@
module Handler.Package.V0.S9PK where

1
src/Handler/Package/V0/Version.hs Normal file
View File

@@ -0,0 +1 @@
module Handler.Package.V0.Version where

29
src/Handler/Types/Api.hs Normal file
View File

@@ -0,0 +1,29 @@
module Handler.Types.Api where
import GHC.Read ( Read(..) )
import GHC.Show ( show )
import Startlude ( Eq
, Maybe(..)
, Ord
, Read
, Show
)
import Yesod ( PathPiece(..) )
data ApiVersion
= V0
| V1 deriving (Eq, Ord)
instance Show ApiVersion where
show V0 = "v0"
show V1 = "v1"
instance Read ApiVersion where
readsPrec = _
instance PathPiece ApiVersion where
toPathPiece V0 = "v0"
toPathPiece V1 = "v1"
fromPathPiece "v0" = Just V0
fromPathPiece "v1" = Just V1
fromPathPiece _ = Nothing

163
src/Handler/Types/Marketplace.hs
View File

@@ -1,163 +0,0 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DeriveGeneric #-}
module Handler.Types.Marketplace where
import Data.Aeson ( (.:)
, FromJSON(parseJSON)
, KeyValue((.=))
, ToJSON(toJSON)
, Value(String)
, object
, withObject
)
import qualified Data.HashMap.Internal.Strict as HM
import Lib.Types.AppIndex ( PkgId )
import Lib.Types.Emver ( Version
, VersionRange
)
import Model ( Category
, PkgDependency
, PkgRecord
, VersionRecord
)
import Startlude ( ($)
, (.)
, Applicative(pure)
, Eq
, Generic
, Int
, Maybe
, Read
, Show
, Text
)
import Yesod ( Entity
, ToContent(..)
, ToTypedContent(..)
)
type URL = Text
type CategoryTitle = Text
data InfoRes = InfoRes
{ name :: !Text
, categories :: ![CategoryTitle]
}
deriving (Show, Generic)
instance ToJSON InfoRes
instance ToContent InfoRes where
toContent = toContent . toJSON
instance ToTypedContent InfoRes where
toTypedContent = toTypedContent . toJSON
data PackageRes = PackageRes
{ packageResIcon :: !URL
, packageResManifest :: !Data.Aeson.Value -- PackageManifest
, packageResCategories :: ![CategoryTitle]
, packageResInstructions :: !URL
, packageResLicense :: !URL
, packageResVersions :: ![Version]
, packageResDependencies :: !(HM.HashMap PkgId DependencyRes)
}
deriving (Show, Generic)
newtype ReleaseNotes = ReleaseNotes { unReleaseNotes :: HM.HashMap Version Text }
deriving (Eq, Show)
instance ToJSON ReleaseNotes where
toJSON ReleaseNotes {..} = object [ t .= v | (k, v) <- HM.toList unReleaseNotes, let (String t) = toJSON k ]
instance ToContent ReleaseNotes where
toContent = toContent . toJSON
instance ToTypedContent ReleaseNotes where
toTypedContent = toTypedContent . toJSON
instance ToJSON PackageRes where
toJSON PackageRes {..} = object
[ "icon" .= packageResIcon
, "license" .= packageResLicense
, "instructions" .= packageResInstructions
, "manifest" .= packageResManifest
, "categories" .= packageResCategories
, "versions" .= packageResVersions
, "dependency-metadata" .= packageResDependencies
]
instance FromJSON PackageRes where
parseJSON = withObject "PackageRes" $ \o -> do
packageResIcon <- o .: "icon"
packageResLicense <- o .: "license"
packageResInstructions <- o .: "instructions"
packageResManifest <- o .: "manifest"
packageResCategories <- o .: "categories"
packageResVersions <- o .: "versions"
packageResDependencies <- o .: "dependency-metadata"
pure PackageRes { .. }
data DependencyRes = DependencyRes
{ dependencyResTitle :: !Text
, dependencyResIcon :: !Text
}
deriving (Eq, Show)
instance ToJSON DependencyRes where
toJSON DependencyRes {..} = object ["icon" .= dependencyResIcon, "title" .= dependencyResTitle]
instance FromJSON DependencyRes where
parseJSON = withObject "DependencyRes" $ \o -> do
dependencyResIcon <- o .: "icon"
dependencyResTitle <- o .: "title"
pure DependencyRes { .. }
newtype PackageListRes = PackageListRes [PackageRes]
deriving (Generic)
instance ToJSON PackageListRes
instance ToContent PackageListRes where
toContent = toContent . toJSON
instance ToTypedContent PackageListRes where
toTypedContent = toTypedContent . toJSON
newtype VersionLatestRes = VersionLatestRes (HM.HashMap PkgId (Maybe Version))
deriving (Show, Generic)
instance ToJSON VersionLatestRes
instance ToContent VersionLatestRes where
toContent = toContent . toJSON
instance ToTypedContent VersionLatestRes where
toTypedContent = toTypedContent . toJSON
data OrderArrangement = ASC | DESC
deriving (Eq, Show, Read)
data PackageListDefaults = PackageListDefaults
{ packageListOrder :: !OrderArrangement
, packageListPageLimit :: !Int -- the number of items per page
, packageListPageNumber :: !Int -- the page you are on
, packageListCategory :: !(Maybe CategoryTitle)
, packageListQuery :: !Text
}
deriving (Eq, Show, Read)
data EosRes = EosRes
{ eosResVersion :: !Version
, eosResHeadline :: !Text
, eosResReleaseNotes :: !ReleaseNotes
}
deriving (Eq, Show, Generic)
instance ToJSON EosRes where
toJSON EosRes {..} =
object ["version" .= eosResVersion, "headline" .= eosResHeadline, "release-notes" .= eosResReleaseNotes]
instance ToContent EosRes where
toContent = toContent . toJSON
instance ToTypedContent EosRes where
toTypedContent = toTypedContent . toJSON
data PackageReq = PackageReq
{ packageReqId :: !PkgId
, packageReqVersion :: !VersionRange
}
deriving Show
instance FromJSON PackageReq where
parseJSON = withObject "package version" $ \o -> do
packageReqId <- o .: "id"
packageReqVersion <- o .: "version"
pure PackageReq { .. }
data PackageMetadata = PackageMetadata
{ packageMetadataPkgId :: !PkgId
, packageMetadataPkgVersionRecords :: ![Entity VersionRecord]
, packageMetadataPkgCategories :: ![Entity Category]
, packageMetadataPkgVersion :: !Version
}
deriving (Eq, Show)
data PackageDependencyMetadata = PackageDependencyMetadata
{ packageDependencyMetadataPkgDependencyRecord :: !(Entity PkgDependency)
, packageDependencyMetadataDepPkgRecord :: !(Entity PkgRecord)
, packageDependencyMetadataDepVersions :: ![Entity VersionRecord]
}
deriving (Eq, Show)

83
src/Handler/Util.hs Normal file
View File

@@ -0,0 +1,83 @@
module Handler.Util where
import Control.Monad.Reader.Has (
Has,
MonadReader,
)
import Data.Text qualified as T
import Data.Text.Lazy qualified as TL
import Data.Text.Lazy.Builder qualified as TB
import Lib.PkgRepository (PkgRepo, getHash)
import Lib.Types.AppIndex (PkgId)
import Lib.Types.Emver (
Version (Version),
VersionRange,
)
import Network.HTTP.Types (
Status,
status400,
)
import Startlude (
Bool (..),
Foldable (foldMap),
Maybe (..),
Semigroup ((<>)),
Text,
fromMaybe,
isSpace,
not,
pure,
readMaybe,
(.),
(<$>),
(>>=),, ($)
)
import UnliftIO (MonadUnliftIO)
import Yesod (
MonadHandler,
RenderRoute (Route),
TypedContent (..),
lookupGetParam,
sendResponseStatus,
toContent,
typePlain,
)
orThrow :: MonadHandler m => m (Maybe a) -> m a -> m a
orThrow action other =
action >>= \case
Nothing -> other
Just x -> pure x
sendResponseText :: MonadHandler m => Status -> Text -> m a
sendResponseText s = sendResponseStatus s . TypedContent typePlain . toContent
getVersionSpecFromQuery :: MonadHandler m => m VersionRange
getVersionSpecFromQuery = do
specString <- T.filter (not . isSpace) . fromMaybe "*" <$> lookupGetParam "spec"
case readMaybe specString of
Nothing -> sendResponseStatus status400 ("Invalid App Version Specification" :: Text)
Just t -> pure t
versionPriorityFromQueryIsMin :: MonadHandler m => m Bool
versionPriorityFromQueryIsMin = do
priorityString <- lookupGetParam "version-priority"
case priorityString of
Nothing -> pure False
(Just "max") -> pure False
(Just "min") -> pure True
(Just t) -> sendResponseStatus status400 ("Invalid Version Priority Specification: " <> t)
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
basicRender :: RenderRoute a => Route a -> Text
basicRender = TL.toStrict . TB.toLazyText . foldMap (mappend (TB.singleton '/') . TB.fromText) . fst . renderRoute

2
src/Handler/Version.hs
View File

@@ -14,12 +14,12 @@ import Data.String.Interpolate.IsString
( i )
import Foundation ( Handler )
import Handler.Types.Status ( AppVersionRes(AppVersionRes) )
import Handler.Util ( orThrow )
import Lib.Error ( S9Error(NotFoundE) )
import Lib.PkgRepository ( getBestVersion )
import Lib.Types.AppIndex ( PkgId )
import Network.HTTP.Types.Status ( status404 )
import Util.Shared ( getVersionSpecFromQuery
, orThrow
, versionPriorityFromQueryIsMin
)

79
src/Lib/Conduit.hs Normal file
View File

@@ -0,0 +1,79 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
module Lib.Conduit where
import Conduit (ConduitT, awaitForever, yield)
import Control.Monad.Logger (logInfo)
import Control.Monad.Logger.CallStack (MonadLogger)
import Data.List (lookup, null)
import Data.String.Interpolate.IsString (i)
import Database.Marketplace (PackageDependencyMetadata (..), PackageMetadata (..))
import Database.Persist (Entity (..))
import Lib.Types.AppIndex (PkgId)
import Lib.Types.Emver (Version, VersionRange (..), satisfies)
import Model (Category, Key, PkgDependency (..), PkgRecord (PkgRecord), VersionRecord (..))
import Startlude (Bool, Down (..), Maybe (..), Monad, Text, filter, fmap, fromMaybe, headMay, sortOn, unless, ($), (.))
filterPkgOsCompatible :: Monad m => (Version -> Bool) -> ConduitT PackageMetadata PackageMetadata m ()
filterPkgOsCompatible p =
awaitForever $
\PackageMetadata{packageMetadataPkgId = pkg, packageMetadataPkgVersionRecords = versions, packageMetadataPkgCategories = cats, packageMetadataPkgVersion = requestedVersion} ->
do
let compatible = filter (p . versionRecordOsVersion . entityVal) versions
unless (null compatible) $
yield
PackageMetadata
{ packageMetadataPkgId = pkg
, packageMetadataPkgVersionRecords = compatible
, packageMetadataPkgCategories = cats
, packageMetadataPkgVersion = requestedVersion
}
filterLatestVersionFromSpec ::
(Monad m, MonadLogger m) =>
[(PkgId, VersionRange)] ->
ConduitT (PkgId, [Entity VersionRecord], [Entity Category]) PackageMetadata m ()
filterLatestVersionFromSpec versionMap = awaitForever $ \(pkgId, vs, cats) -> do
-- if no packages are specified, the VersionRange is implicitly `*`
let spec = fromMaybe Any $ lookup pkgId versionMap
case headMay . sortOn Down $ filter (`satisfies` spec) $ fmap (versionRecordNumber . entityVal) vs of
Nothing -> $logInfo [i|No version for #{pkgId} satisfying #{spec}|]
Just v ->
yield $
PackageMetadata
{ packageMetadataPkgId = pkgId
, packageMetadataPkgVersionRecords = vs
, packageMetadataPkgCategories = cats
, packageMetadataPkgVersion = v
}
filterDependencyOsCompatible :: (Version -> Bool) -> PackageDependencyMetadata -> PackageDependencyMetadata
filterDependencyOsCompatible p PackageDependencyMetadata{packageDependencyMetadataPkgDependencyRecord = pkgDeps, packageDependencyMetadataDepPkgRecord = pkg, packageDependencyMetadataDepVersions = depVersions} =
do
let compatible = filter (p . versionRecordOsVersion . entityVal) depVersions
PackageDependencyMetadata
{ packageDependencyMetadataPkgDependencyRecord = pkgDeps
, packageDependencyMetadataDepPkgRecord = pkg
, packageDependencyMetadataDepVersions = compatible
}
-- get best version of the dependency based on what is specified in the db (ie. what is specified in the manifest for the package)
filterDependencyBestVersion :: MonadLogger m => PackageDependencyMetadata -> m (Maybe (Key PkgRecord, Text, Version))
filterDependencyBestVersion PackageDependencyMetadata{packageDependencyMetadataPkgDependencyRecord = pkgDepRecord, packageDependencyMetadataDepVersions = depVersions} =
do
-- get best version from VersionRange of dependency
let pkgId = pkgDependencyPkgId $ entityVal pkgDepRecord
let depId = pkgDependencyDepId $ entityVal pkgDepRecord
let versionRequirement = pkgDependencyDepVersionRange $ entityVal pkgDepRecord
let satisfactory = filter ((<|| versionRequirement) . versionRecordNumber) (entityVal <$> depVersions)
case maximumOn versionRecordNumber satisfactory of
Just bestVersion -> pure $ Just (depId, versionRecordTitle bestVersion, versionRecordNumber bestVersion)
Nothing -> do
$logInfo
[i|No satisfactory version of #{depId} for dependent package #{pkgId}, needs #{versionRequirement}|]
pure Nothing

11
src/Lib/Ord.hs Normal file
View File

@@ -0,0 +1,11 @@
module Lib.Ord where
import Startlude (Alternative ((<|>)), Foldable (foldr), Maybe (..), Ord ((>)), (<$>))
maximumOn :: forall a b t. (Ord b, Foldable t) => (a -> b) -> t a -> Maybe a
maximumOn f = foldr (\x y -> maxOn f x <$> y <|> Just x) Nothing
maxOn :: Ord b => (a -> b) -> a -> a -> a
maxOn f x y = if f x > f y then x else y

58
src/Startlude.hs
View File

@@ -1,33 +1,37 @@
module Startlude
( module X
, module Startlude
) where
module Startlude (
module X,
module Startlude,
) where
import Control.Arrow as X (
(&&&),
)
import Control.Error.Util as X
import Data.Coerce as X
import Data.String as X (
String,
fromString,
)
import Data.Time.Clock as X
import Protolude as X hiding (
bool,
hush,
isLeft,
isRight,
note,
readMaybe,
tryIO,
(<.>),
)
import Protolude qualified as P (
readMaybe,
)
import Control.Arrow as X
( (&&&) )
import Control.Error.Util as X
import Data.Coerce as X
import Data.String as X
( String
, fromString
)
import Data.Time.Clock as X
import Protolude as X
hiding ( (<.>)
, bool
, hush
, isLeft
, isRight
, note
, readMaybe
, tryIO
)
import qualified Protolude as P
( readMaybe )
id :: a -> a
id = identity
readMaybe :: Read a => Text -> Maybe a
readMaybe = P.readMaybe . toS
readMaybe :: (Read a) => Text -> Maybe a
readMaybe = P.readMaybe
{-# INLINE readMaybe #-}

171
src/Util/Shared.hs
View File

@@ -1,171 +0,0 @@
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}
module Util.Shared where
import qualified Data.Text as T
import Network.HTTP.Types ( Status
, status400
)
import Yesod.Core ( MonadHandler
, MonadLogger
, MonadUnliftIO
, ToContent(toContent)
, TypedContent(TypedContent)
, addHeader
, logInfo
, lookupGetParam
, sendResponseStatus
, typePlain
)
import Conduit ( ConduitT
, awaitForever
, yield
)
import Control.Monad.Reader.Has ( Has
, MonadReader
)
import Data.Semigroup ( (<>) )
import Data.String.Interpolate.IsString
( i )
import Database.Esqueleto.Experimental
( Entity
, Key
, entityVal
)
import Foundation ( Handler )
import GHC.List ( lookup )
import Handler.Types.Marketplace ( PackageDependencyMetadata(..)
, PackageMetadata(..)
)
import Lib.PkgRepository ( PkgRepo
, getHash
)
import Lib.Types.AppIndex ( PkgId )
import Lib.Types.Emver ( (<||)
, Version
, VersionRange(Any)
, satisfies
)
import Model ( Category
, PkgDependency(pkgDependencyDepId, pkgDependencyDepVersionRange)
, PkgRecord
, VersionRecord(..)
, pkgDependencyPkgId
)
import Startlude ( ($)
, (.)
, (<$>)
, Alternative((<|>))
, Applicative(pure)
, Bool(..)
, Down(Down)
, Foldable(foldr, null)
, Functor(fmap)
, Maybe(..)
, Monad((>>=))
, Ord((>))
, Text
, decodeUtf8
, filter
, fromMaybe
, headMay
, isSpace
, not
, readMaybe
, sortOn
, unless
)
getVersionSpecFromQuery :: Handler VersionRange
getVersionSpecFromQuery = do
specString <- T.filter (not . isSpace) . fromMaybe "*" <$> lookupGetParam "spec"
case readMaybe specString of
Nothing -> sendResponseStatus status400 ("Invalid App Version Specification" :: Text)
Just t -> pure t
versionPriorityFromQueryIsMin :: Handler Bool
versionPriorityFromQueryIsMin = do
priorityString <- lookupGetParam "version-priority"
case priorityString of
Nothing -> pure False
(Just "max") -> pure False
(Just "min") -> pure True
(Just t ) -> sendResponseStatus status400 ("Invalid Version Priority Specification: " <> t)
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
filterPkgOsCompatible :: Monad m => (Version -> Bool) -> ConduitT PackageMetadata PackageMetadata m ()
filterPkgOsCompatible p =
awaitForever
$ \PackageMetadata { packageMetadataPkgId = pkg, packageMetadataPkgVersionRecords = versions, packageMetadataPkgCategories = cats, packageMetadataPkgVersion = requestedVersion } ->
do
let compatible = filter (p . versionRecordOsVersion . entityVal) versions
unless (null compatible) $ yield PackageMetadata { packageMetadataPkgId = pkg
, packageMetadataPkgVersionRecords = compatible
, packageMetadataPkgCategories = cats
, packageMetadataPkgVersion = requestedVersion
}
filterDependencyOsCompatible :: (Version -> Bool) -> PackageDependencyMetadata -> PackageDependencyMetadata
filterDependencyOsCompatible p PackageDependencyMetadata { packageDependencyMetadataPkgDependencyRecord = pkgDeps, packageDependencyMetadataDepPkgRecord = pkg, packageDependencyMetadataDepVersions = depVersions }
= do
let compatible = filter (p . versionRecordOsVersion . entityVal) depVersions
PackageDependencyMetadata { packageDependencyMetadataPkgDependencyRecord = pkgDeps
, packageDependencyMetadataDepPkgRecord = pkg
, packageDependencyMetadataDepVersions = compatible
}
filterLatestVersionFromSpec :: (Monad m, MonadLogger m)
=> [(PkgId, VersionRange)]
-> ConduitT (PkgId, [Entity VersionRecord], [Entity Category]) PackageMetadata m ()
filterLatestVersionFromSpec versionMap = awaitForever $ \(pkgId, vs, cats) -> do
-- if no packages are specified, the VersionRange is implicitly `*`
let spec = fromMaybe Any $ lookup pkgId versionMap
case headMay . sortOn Down $ filter (`satisfies` spec) $ fmap (versionRecordNumber . entityVal) vs of
Nothing -> $logInfo [i|No version for #{pkgId} satisfying #{spec}|]
Just v -> yield $ PackageMetadata { packageMetadataPkgId = pkgId
, packageMetadataPkgVersionRecords = vs
, packageMetadataPkgCategories = cats
, packageMetadataPkgVersion = v
}
-- get best version of the dependency based on what is specified in the db (ie. what is specified in the manifest for the package)
filterDependencyBestVersion :: MonadLogger m => PackageDependencyMetadata -> m (Maybe (Key PkgRecord, Text, Version))
filterDependencyBestVersion PackageDependencyMetadata { packageDependencyMetadataPkgDependencyRecord = pkgDepRecord, packageDependencyMetadataDepVersions = depVersions }
= do
-- get best version from VersionRange of dependency
let pkgId = pkgDependencyPkgId $ entityVal pkgDepRecord
let depId = pkgDependencyDepId $ entityVal pkgDepRecord
let versionRequirement = pkgDependencyDepVersionRange $ entityVal pkgDepRecord
let satisfactory = filter ((<|| versionRequirement) . versionRecordNumber) (entityVal <$> depVersions)
case maximumOn versionRecordNumber satisfactory of
Just bestVersion -> pure $ Just (depId, versionRecordTitle bestVersion, versionRecordNumber bestVersion)
Nothing -> do
$logInfo
[i|No satisfactory version of #{depId} for dependent package #{pkgId}, needs #{versionRequirement}|]
pure Nothing
sendResponseText :: MonadHandler m => Status -> Text -> m a
sendResponseText s = sendResponseStatus s . TypedContent typePlain . toContent
maximumOn :: forall a b t . (Ord b, Foldable t) => (a -> b) -> t a -> Maybe a
maximumOn f = foldr (\x y -> maxOn f x <$> y <|> Just x) Nothing
maxOn :: Ord b => (a -> b) -> a -> a -> a
maxOn f x y = if f x > f y then x else y

15
stack.yaml
View File

@@ -17,7 +17,7 @@
#
# resolver: ./custom-snapshot.yaml
# resolver: https://example.com/snapshots/2018-01-01.yaml
resolver: lts-18.11
resolver: nightly-2022-06-06
# User packages to be built.
# Various formats can be used as shown in the example below.
@@ -40,15 +40,14 @@ packages:
# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
#
extra-deps:
- protolude-0.3.0
- esqueleto-3.5.1.0
- protolude-0.3.1
- monad-logger-extras-0.1.1.1
- persistent-migration-0.3.0
- rainbow-0.34.2.2
- terminal-progress-bar-0.4.1
- wai-request-spec-0.10.2.4
- warp-3.3.19
- yesod-auth-basic-0.1.0.3
# - rainbow-0.34.2.2
# - terminal-progress-bar-0.4.1
# - wai-request-spec-0.10.2.4
# - warp-3.3.19
# - yesod-auth-basic-0.1.0.3
# Override default flag values for local packages and extra-deps
# flags: {}