Start9/registry
2
0
Fork 0
mirror of https://github.com/Start9Labs/registry.git synced 2026-03-30 11:51:57 +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.hp
start9-registry.pdf start9-registry.pdf
start9-registry.aux start9-registry.aux
start9-registry.ps start9-registry.ps
shell.nix
testdata/

2
Makefile
View File

@@ -1,2 +1,4 @@
all: all:
stack build --local-bin-path dist --copy-bins 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 /eos/v0/eos.img EosR GET -- get eos.img
-- PACKAGE API V0 -- PACKAGE API V0
/package/v0/info InfoR GET -- get all marketplace categories /package/#ApiVersion/info InfoR GET -- get all marketplace categories
/package/v0/index PackageListR GET -- filter marketplace services by various query params /package/#ApiVersion/index PackageIndexR GET -- filter marketplace services by various query params
/package/v0/latest VersionLatestR GET -- get latest version of apps in query param id /package/#ApiVersion/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/#ApiVersion/#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/#ApiVersion/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/#ApiVersion/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/#ApiVersion/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/#ApiVersion/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/#ApiVersion/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/version/#PkgId PkgVersionR GET -- get most recent appId version
-- SUPPORT API V0 -- SUPPORT API V0
/support/v0/error-logs ErrorLogsR POST /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 version: 0.2.1
default-extensions: default-extensions:
- FlexibleInstances
- GeneralizedNewtypeDeriving
- LambdaCase
- MultiWayIf
- NamedFieldPuns
- NoImplicitPrelude - NoImplicitPrelude
- NumericUnderscores - GHC2021
- LambdaCase
- OverloadedStrings - OverloadedStrings
- StandaloneDeriving
dependencies: dependencies:
- base >=4.12 && <5 - base >=4.12 && <5

13
src/Application.hs
View File

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

336
src/Database/Marketplace.hs
View File

@@ -1,107 +1,127 @@
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Fuse on/on" #-} {-# HLINT ignore "Fuse on/on" #-}
module Database.Marketplace where module Database.Marketplace where
import Conduit ( ConduitT import Conduit (
, MonadResource ConduitT,
, MonadUnliftIO MonadResource,
, awaitForever MonadUnliftIO,
, leftover awaitForever,
, yield leftover,
) yield,
import Control.Monad.Loops ( unfoldM ) )
import Data.Conduit ( await ) import Control.Monad.Loops (unfoldM)
import Database.Esqueleto.Experimental import Data.Conduit (await)
( (%) import Database.Esqueleto.Experimental (
, (&&.) asc,
, (++.) desc,
, (:&)(..) from,
, (==.) groupBy,
, (^.) ilike,
, asc in_,
, desc innerJoin,
, from on,
, groupBy orderBy,
, ilike select,
, in_ selectSource,
, innerJoin table,
, on val,
, orderBy valList,
, select where_,
, selectSource (%),
, table (&&.),
, val (++.),
, valList (:&) (..),
, where_ (==.),
, (||.) (^.),
) (||.),
import qualified Database.Persist as P )
import Database.Persist.Postgresql ( ConnectionPool import Database.Persist qualified as P
, Entity(entityKey, entityVal) import Database.Persist.Postgresql (
, PersistEntity(Key) ConnectionPool,
, SqlBackend Entity (entityKey, entityVal),
, runSqlPool PersistEntity (Key),
) SqlBackend,
import Handler.Types.Marketplace ( PackageDependencyMetadata(..) ) runSqlPool,
import Lib.Types.AppIndex ( PkgId ) )
import Lib.Types.Emver ( Version ) import Lib.Types.AppIndex (PkgId)
import Model ( Category import Lib.Types.Emver (Version)
, EntityField import Model (
( CategoryId Category,
, CategoryName EntityField (
, PkgCategoryCategoryId CategoryId,
, PkgCategoryPkgId CategoryName,
, PkgDependencyDepId PkgCategoryCategoryId,
, PkgDependencyPkgId PkgCategoryPkgId,
, PkgDependencyPkgVersion PkgDependencyDepId,
, PkgRecordId PkgDependencyPkgId,
, VersionRecordDescLong PkgDependencyPkgVersion,
, VersionRecordDescShort PkgRecordId,
, VersionRecordNumber VersionRecordDescLong,
, VersionRecordPkgId VersionRecordDescShort,
, VersionRecordTitle VersionRecordNumber,
, VersionRecordUpdatedAt VersionRecordPkgId,
) VersionRecordTitle,
, Key(PkgRecordKey, unPkgRecordKey) VersionRecordUpdatedAt
, PkgCategory ),
, PkgDependency Key (PkgRecordKey, unPkgRecordKey),
, PkgRecord PkgCategory,
, VersionRecord(versionRecordNumber, versionRecordPkgId) PkgDependency,
) PkgRecord,
import Startlude ( ($) VersionRecord (versionRecordNumber, versionRecordPkgId),
, ($>) )
, (.) import Startlude (
, (<$>) Applicative (pure),
, Applicative(pure) Down (Down),
, Down(Down) Eq ((==)),
, Eq((==)) Functor (fmap),
, Functor(fmap) Maybe (..),
, Maybe(..) Monad,
, Monad MonadIO,
, MonadIO ReaderT,
, ReaderT Show,
, Text Text,
, headMay headMay,
, lift lift,
, snd snd,
, sortOn sortOn,
) ($),
($>),
(.),
(<$>),
)
type CategoryTitle = Text
searchServices :: (MonadResource m, MonadIO m) data PackageMetadata = PackageMetadata
=> Maybe CategoryTitle { packageMetadataPkgId :: !PkgId
-> Text , packageMetadataPkgVersionRecords :: ![Entity VersionRecord]
-> ConduitT () (Entity VersionRecord) (ReaderT SqlBackend m) () , 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 searchServices Nothing query = selectSource $ do
service <- from $ table @VersionRecord service <- from $ table @VersionRecord
where_ where_
( (service ^. VersionRecordDescShort `ilike` (%) ++. val query ++. (%)) ( (service ^. VersionRecordDescShort `ilike` (%) ++. val query ++. (%))
||. (service ^. VersionRecordDescLong `ilike` (%) ++. val query ++. (%)) ||. (service ^. VersionRecordDescLong `ilike` (%) ++. val query ++. (%))
||. (service ^. VersionRecordTitle `ilike` (%) ++. val query ++. (%)) ||. (service ^. VersionRecordTitle `ilike` (%) ++. val query ++. (%))
) )
groupBy (service ^. VersionRecordPkgId, service ^. VersionRecordNumber) groupBy (service ^. VersionRecordPkgId, service ^. VersionRecordNumber)
orderBy orderBy
@@ -111,27 +131,28 @@ searchServices Nothing query = selectSource $ do
] ]
pure service pure service
searchServices (Just category) query = selectSource $ do searchServices (Just category) query = selectSource $ do
services <- from services <-
(do from
(service :& _ :& cat) <- ( do
from (service :& _ :& cat) <-
$ table @VersionRecord from $
`innerJoin` table @PkgCategory table @VersionRecord
`on` (\(s :& sc) -> sc ^. PkgCategoryPkgId ==. s ^. VersionRecordPkgId) `innerJoin` table @PkgCategory
`innerJoin` table @Category `on` (\(s :& sc) -> sc ^. PkgCategoryPkgId ==. s ^. VersionRecordPkgId)
`on` (\(_ :& sc :& cat) -> sc ^. PkgCategoryCategoryId ==. cat ^. CategoryId) `innerJoin` table @Category
-- if there is a cateogry, only search in category `on` (\(_ :& sc :& cat) -> sc ^. PkgCategoryCategoryId ==. cat ^. CategoryId)
-- weight title, short, long (bitcoin should equal Bitcoin Core) -- if there is a cateogry, only search in category
where_ -- weight title, short, long (bitcoin should equal Bitcoin Core)
$ cat where_ $
^. CategoryName cat
==. val category ^. CategoryName
&&. ( (service ^. VersionRecordDescShort `ilike` (%) ++. val query ++. (%)) ==. val category
||. (service ^. VersionRecordDescLong `ilike` (%) ++. val query ++. (%)) &&. ( (service ^. VersionRecordDescShort `ilike` (%) ++. val query ++. (%))
||. (service ^. VersionRecordTitle `ilike` (%) ++. val query ++. (%)) ||. (service ^. VersionRecordDescLong `ilike` (%) ++. val query ++. (%))
) ||. (service ^. VersionRecordTitle `ilike` (%) ++. val query ++. (%))
pure service )
) pure service
)
groupBy (services ^. VersionRecordPkgId, services ^. VersionRecordNumber) groupBy (services ^. VersionRecordPkgId, services ^. VersionRecordNumber)
orderBy orderBy
[ asc (services ^. VersionRecordPkgId) [ asc (services ^. VersionRecordPkgId)
@@ -140,48 +161,56 @@ searchServices (Just category) query = selectSource $ do
] ]
pure services pure services
getPkgData :: (MonadResource m, MonadIO m) => [PkgId] -> ConduitT () (Entity VersionRecord) (ReaderT SqlBackend m) () getPkgData :: (MonadResource m, MonadIO m) => [PkgId] -> ConduitT () (Entity VersionRecord) (ReaderT SqlBackend m) ()
getPkgData pkgs = selectSource $ do getPkgData pkgs = selectSource $ do
pkgData <- from $ table @VersionRecord pkgData <- from $ table @VersionRecord
where_ (pkgData ^. VersionRecordPkgId `in_` valList (PkgRecordKey <$> pkgs)) where_ (pkgData ^. VersionRecordPkgId `in_` valList (PkgRecordKey <$> pkgs))
pure pkgData pure pkgData
getPkgDependencyData :: MonadIO m
=> Key PkgRecord getPkgDependencyData ::
-> Version MonadIO m =>
-> ReaderT SqlBackend m [(Entity PkgDependency, Entity PkgRecord)] Key PkgRecord ->
Version ->
ReaderT SqlBackend m [(Entity PkgDependency, Entity PkgRecord)]
getPkgDependencyData pkgId pkgVersion = select $ do getPkgDependencyData pkgId pkgVersion = select $ do
from from
(do ( do
(pkgDepRecord :& depPkgRecord) <- (pkgDepRecord :& depPkgRecord) <-
from from $
$ table @PkgDependency table @PkgDependency
`innerJoin` table @PkgRecord `innerJoin` table @PkgRecord
`on` (\(pdr :& dpr) -> dpr ^. PkgRecordId ==. pdr ^. PkgDependencyDepId) `on` (\(pdr :& dpr) -> dpr ^. PkgRecordId ==. pdr ^. PkgDependencyDepId)
where_ (pkgDepRecord ^. PkgDependencyPkgId ==. val pkgId) where_ (pkgDepRecord ^. PkgDependencyPkgId ==. val pkgId)
where_ (pkgDepRecord ^. PkgDependencyPkgVersion ==. val pkgVersion) where_ (pkgDepRecord ^. PkgDependencyPkgVersion ==. val pkgVersion)
pure (pkgDepRecord, depPkgRecord) pure (pkgDepRecord, depPkgRecord)
) )
zipCategories :: MonadUnliftIO m
=> ConduitT zipCategories ::
(PkgId, [Entity VersionRecord]) MonadUnliftIO m =>
(PkgId, [Entity VersionRecord], [Entity Category]) ConduitT
(ReaderT SqlBackend m) (PkgId, [Entity VersionRecord])
() (PkgId, [Entity VersionRecord], [Entity Category])
(ReaderT SqlBackend m)
()
zipCategories = awaitForever $ \(pkg, vers) -> do zipCategories = awaitForever $ \(pkg, vers) -> do
raw <- lift $ select $ do raw <- lift $
(sc :& cat) <- select $ do
from (sc :& cat) <-
$ table @PkgCategory from $
`innerJoin` table @Category table @PkgCategory
`on` (\(sc :& cat) -> sc ^. PkgCategoryCategoryId ==. cat ^. CategoryId) `innerJoin` table @Category
where_ (sc ^. PkgCategoryPkgId ==. val (PkgRecordKey pkg)) `on` (\(sc :& cat) -> sc ^. PkgCategoryCategoryId ==. cat ^. CategoryId)
pure cat where_ (sc ^. PkgCategoryPkgId ==. val (PkgRecordKey pkg))
pure cat
yield (pkg, vers, raw) 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 collateVersions = awaitForever $ \v0 -> do
let pkg = unPkgRecordKey . versionRecordPkgId $ entityVal v0 let pkg = unPkgRecordKey . versionRecordPkgId $ entityVal v0
let pull = do let pull = do
@@ -194,32 +223,39 @@ collateVersions = awaitForever $ \v0 -> do
ls <- unfoldM pull ls <- unfoldM pull
yield (pkg, v0 : ls) yield (pkg, v0 : ls)
zipDependencyVersions :: (Monad m, MonadIO m)
=> (Entity PkgDependency, Entity PkgRecord) zipDependencyVersions ::
-> ReaderT SqlBackend m PackageDependencyMetadata (Monad m, MonadIO m) =>
(Entity PkgDependency, Entity PkgRecord) ->
ReaderT SqlBackend m PackageDependencyMetadata
zipDependencyVersions (pkgDepRecord, depRecord) = do zipDependencyVersions (pkgDepRecord, depRecord) = do
let pkgDbId = entityKey depRecord let pkgDbId = entityKey depRecord
depVers <- select $ do depVers <- select $ do
v <- from $ table @VersionRecord v <- from $ table @VersionRecord
where_ $ v ^. VersionRecordPkgId ==. val pkgDbId where_ $ v ^. VersionRecordPkgId ==. val pkgDbId
pure v pure v
pure $ PackageDependencyMetadata { packageDependencyMetadataPkgDependencyRecord = pkgDepRecord pure $
, packageDependencyMetadataDepPkgRecord = depRecord PackageDependencyMetadata
, packageDependencyMetadataDepVersions = depVers { packageDependencyMetadataPkgDependencyRecord = pkgDepRecord
} , packageDependencyMetadataDepPkgRecord = depRecord
, packageDependencyMetadataDepVersions = depVers
}
fetchAllAppVersions :: MonadUnliftIO m => ConnectionPool -> PkgId -> m [VersionRecord] fetchAllAppVersions :: MonadUnliftIO m => ConnectionPool -> PkgId -> m [VersionRecord]
fetchAllAppVersions appConnPool appId = do fetchAllAppVersions appConnPool appId = do
entityAppVersions <- runSqlPool (P.selectList [VersionRecordPkgId P.==. PkgRecordKey appId] []) appConnPool entityAppVersions <- runSqlPool (P.selectList [VersionRecordPkgId P.==. PkgRecordKey appId] []) appConnPool
pure $ entityVal <$> entityAppVersions pure $ entityVal <$> entityAppVersions
fetchLatestApp :: MonadIO m => PkgId -> ReaderT SqlBackend m (Maybe (P.Entity PkgRecord, P.Entity VersionRecord)) fetchLatestApp :: MonadIO m => PkgId -> ReaderT SqlBackend m (Maybe (P.Entity PkgRecord, P.Entity VersionRecord))
fetchLatestApp appId = fmap headMay . sortResults . select $ do fetchLatestApp appId = fmap headMay . sortResults . select $ do
(service :& version) <- (service :& version) <-
from from $
$ table @PkgRecord table @PkgRecord
`innerJoin` table @VersionRecord `innerJoin` table @VersionRecord
`on` (\(service :& version) -> service ^. PkgRecordId ==. version ^. VersionRecordPkgId) `on` (\(service :& version) -> service ^. PkgRecordId ==. version ^. VersionRecordPkgId)
where_ (service ^. PkgRecordId ==. val (PkgRecordKey appId)) where_ (service ^. PkgRecordId ==. val (PkgRecordKey appId))
pure (service, version) 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 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 BangPatterns #-} {-# 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 module Foundation where
import Startlude ( ($) import Startlude (
, (.) Applicative (pure),
, (<$>) Bool (False),
, (<&>) Eq ((==)),
, (<**>) IO,
, (=<<) MVar,
, Applicative(pure) Maybe (..),
, Bool(False) Monad (return),
, Eq((==)) Monoid (mempty),
, IO Semigroup ((<>)),
, MVar String,
, Maybe(..) Text,
, Monad(return) ThreadId,
, Monoid(mempty) Word64,
, Semigroup((<>)) decodeUtf8,
, String drop,
, Text encodeUtf8,
, ThreadId flip,
, Word64 fst,
, decodeUtf8 isJust,
, drop otherwise,
, encodeUtf8 putMVar,
, flip show,
, fst when,
, isJust ($),
, otherwise (.),
, putMVar (<$>),
, show (<&>),
, when (<**>),
, (||) (=<<),
) (||),
)
import Control.Monad.Logger ( Loc import Control.Monad.Logger (
, LogSource Loc,
, LogStr LogSource,
, ToLogStr(toLogStr) LogStr,
, fromLogStr ToLogStr (toLogStr),
) fromLogStr,
import Database.Persist.Sql ( ConnectionPool )
, LogFunc import Database.Persist.Sql (
, PersistStoreRead(get) ConnectionPool,
, SqlBackend LogFunc,
, SqlPersistT PersistStoreRead (get),
, runSqlPool SqlBackend,
) SqlPersistT,
import Lib.Registry ( S9PK ) runSqlPool,
import Yesod.Core ( AuthResult(Authorized, Unauthorized) )
, LogLevel(..) import Lib.Registry (S9PK)
, MonadHandler(liftHandler) import Yesod.Core (
, RenderMessage(..) AuthResult (Authorized, Unauthorized),
, RenderRoute(Route, renderRoute) LogLevel (..),
, RouteAttrs(routeAttrs) MonadHandler (liftHandler),
, SessionBackend RenderMessage (..),
, ToTypedContent RenderRoute (Route, renderRoute),
, Yesod RouteAttrs (routeAttrs),
( isAuthorized SessionBackend,
, makeLogger ToTypedContent,
, makeSessionBackend Yesod (
, maximumContentLengthIO isAuthorized,
, messageLoggerSource makeLogger,
, shouldLogIO makeSessionBackend,
, yesodMiddleware maximumContentLengthIO,
) messageLoggerSource,
, defaultYesodMiddleware shouldLogIO,
, getYesod yesodMiddleware
, getsYesod ),
, mkYesodData defaultYesodMiddleware,
, parseRoutesFile getYesod,
) getsYesod,
import Yesod.Core.Types ( HandlerData(handlerEnv) mkYesodData,
, Logger(loggerDate) parseRoutesFile,
, RunHandlerEnv(rheChild, rheSite) )
, loggerPutStr import Yesod.Core.Types (
) HandlerData (handlerEnv),
import qualified Yesod.Core.Unsafe as Unsafe 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 -- | The foundation datatype for your application. This can be a good place to
-- keep settings and values requiring initialization before your application -- keep settings and values requiring initialization before your application
-- starts running, such as database connections. Every handler will have -- starts running, such as database connections. Every handler will have
-- access to the data present here. -- access to the data present here.
data RegistryCtx = RegistryCtx data RegistryCtx = RegistryCtx
{ appSettings :: AppSettings { appSettings :: AppSettings
, appLogger :: Logger , appLogger :: Logger
, appWebServerThreadId :: MVar (ThreadId, ThreadId) , appWebServerThreadId :: MVar (ThreadId, ThreadId)
, appShouldRestartWeb :: MVar Bool , appShouldRestartWeb :: MVar Bool
, appConnPool :: ConnectionPool , appConnPool :: ConnectionPool
, appStopFsNotifyEos :: IO Bool , appStopFsNotifyEos :: IO Bool
} }
instance Has PkgRepo RegistryCtx where instance Has PkgRepo RegistryCtx where
extract = transitiveExtract @AppSettings extract = transitiveExtract @AppSettings
update = transitiveUpdate @AppSettings update = transitiveUpdate @AppSettings
instance Has a r => Has a (HandlerData r r) where instance Has a r => Has a (HandlerData r r) where
extract = extract . rheSite . handlerEnv extract = extract . rheSite . handlerEnv
update f r = update f r =
let ctx = update f (rheSite $ handlerEnv r) let ctx = update f (rheSite $ handlerEnv r)
rhe = (handlerEnv r) { rheSite = ctx, rheChild = ctx } rhe = (handlerEnv r){rheSite = ctx, rheChild = ctx}
in r { handlerEnv = rhe } in r{handlerEnv = rhe}
instance Has AppSettings RegistryCtx where instance Has AppSettings RegistryCtx where
extract = appSettings extract = appSettings
update f ctx = ctx { appSettings = f (appSettings ctx) } update f ctx = ctx{appSettings = f (appSettings ctx)}
instance Has EosRepo RegistryCtx where instance Has EosRepo RegistryCtx where
extract = transitiveExtract @AppSettings extract = transitiveExtract @AppSettings
update = transitiveUpdate @AppSettings update = transitiveUpdate @AppSettings
{-# INLINE transitiveExtract #-} {-# 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 transitiveExtract = extract @a . extract @b
{-# INLINE transitiveUpdate #-} {-# 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) transitiveUpdate f = update (update @a @b f)
setWebProcessThreadId :: (ThreadId, ThreadId) -> RegistryCtx -> IO () setWebProcessThreadId :: (ThreadId, ThreadId) -> RegistryCtx -> IO ()
setWebProcessThreadId tid@(!_, !_) a = putMVar (appWebServerThreadId a) tid setWebProcessThreadId tid@(!_, !_) a = putMVar (appWebServerThreadId a) tid
-- This is where we define all of the routes in our application. For a full -- This is where we define all of the routes in our application. For a full
-- explanation of the syntax, please see: -- explanation of the syntax, please see:
-- http://www.yesodweb.com/book/routing-and-handlers -- http://www.yesodweb.com/book/routing-and-handlers
@@ -193,68 +212,73 @@ setWebProcessThreadId tid@(!_, !_) a = putMVar (appWebServerThreadId a) tid
-- type Handler = HandlerT RegistryCtx IO -- type Handler = HandlerT RegistryCtx IO
mkYesodData "RegistryCtx" $(parseRoutesFile "config/routes") mkYesodData "RegistryCtx" $(parseRoutesFile "config/routes")
-- Please see the documentation for the Yesod typeclass. There are a number -- Please see the documentation for the Yesod typeclass. There are a number
-- of settings which can be configured by overriding methods here. -- of settings which can be configured by overriding methods here.
instance Yesod RegistryCtx where instance Yesod RegistryCtx where
-- Store session data on the client in encrypted cookies,
-- Store session data on the client in encrypted cookies, -- default session idle timeout is 120 minutes
-- default session idle timeout is 120 minutes
makeSessionBackend :: RegistryCtx -> IO (Maybe SessionBackend) makeSessionBackend :: RegistryCtx -> IO (Maybe SessionBackend)
makeSessionBackend _ = pure Nothing 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. -- Yesod Middleware allows you to run code before and after each handler function.
-- Some users may also want to add the defaultCsrfMiddleware, which: -- The defaultYesodMiddleware adds the response header "Vary: Accept, Accept-Language" and performs authorization checks.
-- a) Sets a cookie with a CSRF token in it. -- Some users may also want to add the defaultCsrfMiddleware, which:
-- b) Validates that incoming write requests include that token in either a header or POST parameter. -- a) Sets a cookie with a CSRF token in it.
-- To add it, chain it together with the defaultMiddleware: yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware -- b) Validates that incoming write requests include that token in either a header or POST parameter.
-- For details, see the CSRF documentation in the Yesod.Core.Handler module of the yesod-core package. -- 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 :: ToTypedContent res => Handler res -> Handler res
yesodMiddleware = defaultYesodMiddleware 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 :: RegistryCtx -> LogSource -> LogLevel -> IO Bool
shouldLogIO app _source level = shouldLogIO app _source level =
return $ appShouldLogAll (appSettings app) || level == LevelInfo || level == LevelWarn || level == LevelError return $ appShouldLogAll (appSettings app) || level == LevelInfo || level == LevelWarn || level == LevelError
makeLogger :: RegistryCtx -> IO Logger makeLogger :: RegistryCtx -> IO Logger
makeLogger = return . appLogger makeLogger = return . appLogger
messageLoggerSource :: RegistryCtx -> Logger -> Loc -> LogSource -> LogLevel -> LogStr -> IO () messageLoggerSource :: RegistryCtx -> Logger -> Loc -> LogSource -> LogLevel -> LogStr -> IO ()
messageLoggerSource ctx logger = \loc src lvl str -> do messageLoggerSource ctx logger = \loc src lvl str -> do
shouldLog <- shouldLogIO ctx src lvl shouldLog <- shouldLogIO ctx src lvl
when shouldLog $ do when shouldLog $ do
date <- loggerDate logger date <- loggerDate logger
let let formatted =
formatted =
toLogStr date toLogStr date
<> ( toLogStr <> ( toLogStr
. wrapSGRCode [SetColor Foreground Vivid (colorFor lvl)] . wrapSGRCode [SetColor Foreground Vivid (colorFor lvl)]
$ fromLogStr $ fromLogStr
( " [" ( " ["
<> renderLvl lvl <> renderLvl lvl
<> (if T.null src then mempty else "#" <> toLogStr src) <> (if T.null src then mempty else "#" <> toLogStr src)
<> "] " <> "] "
<> str <> str
) )
) )
<> toLogStr <> toLogStr
(wrapSGRCode [SetColor Foreground Dull White] ( wrapSGRCode
[i| @ #{loc_filename loc}:#{fst $ loc_start loc}\n|] [SetColor Foreground Dull White]
) [i| @ #{loc_filename loc}:#{fst $ loc_start loc}\n|]
)
loggerPutStr logger formatted loggerPutStr logger formatted
where where
renderLvl lvl = case lvl of renderLvl lvl = case lvl of
LevelOther t -> toLogStr t LevelOther t -> toLogStr t
_ -> toLogStr @String $ drop 5 $ show lvl _ -> toLogStr @String $ drop 5 $ show lvl
colorFor = \case colorFor = \case
LevelDebug -> Green LevelDebug -> Green
LevelInfo -> Blue LevelInfo -> Blue
LevelWarn -> Yellow LevelWarn -> Yellow
LevelError -> Red LevelError -> Red
LevelOther _ -> White LevelOther _ -> White
isAuthorized :: Route RegistryCtx -> Bool -> Handler AuthResult isAuthorized :: Route RegistryCtx -> Bool -> Handler AuthResult
isAuthorized route _ isAuthorized route _
| "admin" `member` routeAttrs route = do | "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" pure $ if hasAuthId then Authorized else Unauthorized "This feature is for admins only"
| otherwise = pure Authorized | otherwise = pure Authorized
maximumContentLengthIO :: RegistryCtx -> Maybe (Route RegistryCtx) -> IO (Maybe Word64) maximumContentLengthIO :: RegistryCtx -> Maybe (Route RegistryCtx) -> IO (Maybe Word64)
maximumContentLengthIO _ (Just PkgUploadR) = pure Nothing maximumContentLengthIO _ (Just PkgUploadR) = pure Nothing
maximumContentLengthIO _ _ = pure $ Just 2097152 -- the original default maximumContentLengthIO _ _ = pure $ Just 2097152 -- the original default
-- How to run database actions. -- How to run database actions.
instance YesodPersist RegistryCtx where instance YesodPersist RegistryCtx where
@@ -272,37 +298,40 @@ instance YesodPersist RegistryCtx where
runDB :: SqlPersistT Handler a -> Handler a runDB :: SqlPersistT Handler a -> Handler a
runDB action = runSqlPool action . appConnPool =<< getYesod runDB action = runSqlPool action . appConnPool =<< getYesod
instance YesodPersistRunner RegistryCtx where instance YesodPersistRunner RegistryCtx where
getDBRunner :: Handler (DBRunner RegistryCtx, Handler ()) getDBRunner :: Handler (DBRunner RegistryCtx, Handler ())
getDBRunner = defaultGetDBRunner appConnPool getDBRunner = defaultGetDBRunner appConnPool
instance RenderMessage RegistryCtx FormMessage where instance RenderMessage RegistryCtx FormMessage where
renderMessage _ _ = defaultFormMessage renderMessage _ _ = defaultFormMessage
instance YesodAuth RegistryCtx where instance YesodAuth RegistryCtx where
type AuthId RegistryCtx = Text type AuthId RegistryCtx = Text
getAuthId = pure . Just . credsIdent getAuthId = pure . Just . credsIdent
maybeAuthId = do maybeAuthId = do
pool <- getsYesod appConnPool pool <- getsYesod appConnPool
let checkCreds k s = flip runSqlPool pool $ do let checkCreds k s = flip runSqlPool pool $ do
let passHash = hashWith SHA256 . encodeUtf8 . ("start9_admin:" <>) $ decodeUtf8 s let passHash = hashWith SHA256 . encodeUtf8 . ("start9_admin:" <>) $ decodeUtf8 s
get (AdminKey $ decodeUtf8 k) <&> \case get (AdminKey $ decodeUtf8 k) <&> \case
Nothing -> False Nothing -> False
Just Admin { adminPassHash } -> adminPassHash == passHash Just Admin{adminPassHash} -> adminPassHash == passHash
defaultMaybeBasicAuthId checkCreds defaultAuthSettings defaultMaybeBasicAuthId checkCreds defaultAuthSettings
loginDest _ = PackageListR loginDest _ = PackageIndexR V1
logoutDest _ = PackageListR logoutDest _ = PackageIndexR V1
authPlugins _ = [] authPlugins _ = []
instance YesodAuthPersist RegistryCtx where instance YesodAuthPersist RegistryCtx where
type AuthEntity RegistryCtx = Admin type AuthEntity RegistryCtx = Admin
getAuthEntity = liftHandler . runDB . get . AdminKey getAuthEntity = liftHandler . runDB . get . AdminKey
unsafeHandler :: RegistryCtx -> Handler a -> IO a unsafeHandler :: RegistryCtx -> Handler a -> IO a
unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger
-- Note: Some functionality previously present in the scaffolding has been -- Note: Some functionality previously present in the scaffolding has been
-- moved to documentation in the Wiki. Following are some hopefully helpful -- moved to documentation in the Wiki. Following are some hopefully helpful
-- links: -- links:

6
src/Handler/Admin.hs
View File

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

150
src/Handler/Apps.hs
View File

@@ -1,98 +1,107 @@
{-# LANGUAGE TupleSections #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
module Handler.Apps where module Handler.Apps where
import Startlude ( ($) import Startlude (
, (.) Applicative (pure),
, Applicative(pure) FilePath,
, FilePath Maybe (..),
, Maybe(..) Monad ((>>=)),
, Monad((>>=)) Show,
, Show String,
, String show,
, show void,
, void ($),
) (.),
)
import Control.Monad.Logger ( logError ) import Control.Monad.Logger (logError)
import qualified Data.Text as T import Data.Text qualified as T
import qualified GHC.Show ( Show(..) ) import GHC.Show qualified (Show (..))
import Network.HTTP.Types ( status404 ) import Network.HTTP.Types (status404)
import System.FilePath ( (<.>) import System.FilePath (
, takeBaseName takeBaseName,
) (<.>),
import Yesod.Core ( Content(ContentFile) )
, TypedContent import Yesod.Core (
, addHeader Content (ContentFile),
, notFound TypedContent,
, respond addHeader,
, respondSource notFound,
, sendChunkBS respond,
, sendResponseStatus respondSource,
, typeJson sendChunkBS,
, typeOctet sendResponseStatus,
) typeJson,
import Yesod.Persist.Core ( YesodPersist(runDB) ) 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) data FileExtension = FileExtension !FilePath !(Maybe String)
instance Show FileExtension where instance Show FileExtension where
show (FileExtension f Nothing ) = f show (FileExtension f Nothing) = f
show (FileExtension f (Just e)) = f <.> e show (FileExtension f (Just e)) = f <.> e
getAppManifestR :: PkgId -> Handler TypedContent getAppManifestR :: PkgId -> Handler TypedContent
getAppManifestR pkg = do getAppManifestR pkg = do
versionSpec <- getVersionSpecFromQuery versionSpec <- getVersionSpecFromQuery
preferMin <- versionPriorityFromQueryIsMin preferMin <- versionPriorityFromQueryIsMin
version <- getBestVersion pkg versionSpec preferMin version <-
`orThrow` sendResponseStatus status404 (NotFoundE [i|#{pkg} satisfying #{versionSpec}|]) getBestVersion pkg versionSpec preferMin
`orThrow` sendResponseStatus status404 (NotFoundE [i|#{pkg} satisfying #{versionSpec}|])
addPackageHeader pkg version addPackageHeader pkg version
(len, src) <- getManifest pkg version (len, src) <- getManifest pkg version
addHeader "Content-Length" (show len) addHeader "Content-Length" (show len)
respondSource typeJson $ src .| awaitForever sendChunkBS respondSource typeJson $ src .| awaitForever sendChunkBS
getAppR :: S9PK -> Handler TypedContent getAppR :: S9PK -> Handler TypedContent
getAppR file = do getAppR file = do
let pkg = PkgId . T.pack $ takeBaseName (show file) let pkg = PkgId . T.pack $ takeBaseName (show file)
versionSpec <- getVersionSpecFromQuery versionSpec <- getVersionSpecFromQuery
preferMin <- versionPriorityFromQueryIsMin preferMin <- versionPriorityFromQueryIsMin
version <- getBestVersion pkg versionSpec preferMin version <-
`orThrow` sendResponseStatus status404 (NotFoundE [i|#{pkg} satisfying #{versionSpec}|]) getBestVersion pkg versionSpec preferMin
`orThrow` sendResponseStatus status404 (NotFoundE [i|#{pkg} satisfying #{versionSpec}|])
addPackageHeader pkg version addPackageHeader pkg version
void $ recordMetrics pkg version void $ recordMetrics pkg version
pkgPath <- getPackage pkg version >>= \case pkgPath <-
Nothing -> sendResponseStatus status404 (NotFoundE [i|#{pkg}@#{version}|]) getPackage pkg version >>= \case
Just a -> pure a Nothing -> sendResponseStatus status404 (NotFoundE [i|#{pkg}@#{version}|])
Just a -> pure a
respond typeOctet $ ContentFile pkgPath Nothing respond typeOctet $ ContentFile pkgPath Nothing
@@ -110,4 +119,3 @@ recordMetrics pkg appVersion = do
$logError [i|#{pkg}@#{appVersion} not found in database|] $logError [i|#{pkg}@#{appVersion} not found in database|]
notFound notFound
Just _ -> runDB $ createMetric pkg appVersion 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 DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
module Handler.Icons where module Handler.Icons where
import Startlude ( ($) import Data.Aeson (FromJSON, ToJSON)
, Eq import Startlude (Eq, Generic, Read, Show)
, Generic
, Read
, Show
, 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 data IconType = PNG | JPG | JPEG | SVG
deriving (Eq, Show, Generic, Read) deriving (Eq, Show, Generic, Read)
instance ToJSON IconType instance ToJSON IconType
instance FromJSON 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 TupleSections #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Redundant <$>" #-} {-# HLINT ignore "Redundant <$>" #-}
module Handler.Marketplace where module Handler.Marketplace where
import Startlude ( ($) import Startlude (
, (&&&) Applicative (pure, (*>)),
, (.) Bool (True),
, (<$>) ByteString,
, (<&>) Down (Down),
, Applicative((*>), pure) Either (Left, Right),
, Bool(True) FilePath,
, ByteString Foldable (foldMap),
, Down(Down) Functor (fmap),
, Either(Left, Right) Int,
, FilePath Maybe (..),
, Foldable(foldMap) Monad ((>>=)),
, Functor(fmap) MonadIO,
, Int MonadReader,
, Maybe(..) Monoid (mappend),
, Monad((>>=)) Num ((*), (-)),
, MonadIO Ord ((<)),
, MonadReader ReaderT (runReaderT),
, Monoid(mappend) Text,
, Num((*), (-)) Traversable (traverse),
, Ord((<)) catMaybes,
, ReaderT(runReaderT) const,
, Text decodeUtf8,
, Traversable(traverse) encodeUtf8,
, catMaybes filter,
, const flip,
, decodeUtf8 for_,
, encodeUtf8 fromMaybe,
, filter fst,
, flip head,
, for_ headMay,
, fromMaybe id,
, fst maybe,
, head partitionEithers,
, headMay readMaybe,
, id show,
, maybe snd,
, partitionEithers void,
, readMaybe ($),
, show (&&&),
, snd (.),
, void (<$>),
) (<&>),
)
import Conduit ( (.|) import Conduit (
, dropC dropC,
, runConduit runConduit,
, sinkList sinkList,
, takeC takeC,
) (.|),
import Control.Monad.Logger ( MonadLogger )
, logWarn import Control.Monad.Logger (
) MonadLogger,
import Control.Monad.Reader.Has ( Has logWarn,
, ask )
) import Control.Monad.Reader.Has (
import Crypto.Hash ( SHA256 ) Has,
import Crypto.Hash.Conduit ( hashFile ) ask,
import Data.Aeson ( decode )
, eitherDecode import Crypto.Hash (SHA256)
, eitherDecodeStrict import Crypto.Hash.Conduit (hashFile)
) import Data.Aeson (
import qualified Data.Attoparsec.Text as Atto 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 :: MonadHandler m => Text -> Parser a -> m (Maybe a)
queryParamAs k p = lookupGetParam k >>= \case queryParamAs k p =
Nothing -> pure Nothing lookupGetParam k >>= \case
Just x -> case parseOnly p x of Nothing -> pure Nothing
Left e -> Just x -> case parseOnly p x of
sendResponseStatus @_ @Text status400 [i|Invalid Request! The query parameter '#{k}' failed to parse: #{e}|] Left e ->
Right a -> pure (Just a) sendResponseStatus @_ @Text status400 [i|Invalid Request! The query parameter '#{k}' failed to parse: #{e}|]
Right a -> pure (Just a)
getInfoR :: Handler (JSONResponse InfoRes) getInfoR :: Handler (JSONResponse InfoRes)
getInfoR = do getInfoR = do
name <- getsYesod $ marketplaceName . appSettings name <- getsYesod $ marketplaceName . appSettings
allCategories <- runDB $ select $ do allCategories <- runDB $
cats <- from $ table @Category select $ do
orderBy [asc (cats ^. CategoryPriority)] cats <- from $ table @Category
pure cats orderBy [asc (cats ^. CategoryPriority)]
pure cats
pure $ JSONResponse $ InfoRes name $ categoryName . entityVal <$> allCategories pure $ JSONResponse $ InfoRes name $ categoryName . entityVal <$> allCategories
getEosVersionR :: Handler (JSONResponse (Maybe EosRes)) getEosVersionR :: Handler (JSONResponse (Maybe EosRes))
getEosVersionR = do getEosVersionR = do
eosVersion <- queryParamAs "eos-version" parseVersion eosVersion <- queryParamAs "eos-version" parseVersion
allEosVersions <- runDB $ select $ do allEosVersions <- runDB $
vers <- from $ table @OsVersion select $ do
orderBy [desc (vers ^. OsVersionCreatedAt)] vers <- from $ table @OsVersion
pure vers orderBy [desc (vers ^. OsVersionCreatedAt)]
let osV = entityVal <$> allEosVersions pure vers
let osV = entityVal <$> allEosVersions
let mLatest = head osV let mLatest = head osV
let mappedVersions = let mappedVersions =
ReleaseNotes ReleaseNotes $
$ HM.fromList HM.fromList $
$ sortOn (Down . fst) sortOn (Down . fst) $
$ filter (maybe (const True) (<) eosVersion . fst) filter (maybe (const True) (<) eosVersion . fst) $
$ (\v -> (osVersionNumber v, osVersionReleaseNotes v)) (\v -> (osVersionNumber v, osVersionReleaseNotes v))
<$> osV <$> osV
pure . JSONResponse $ mLatest <&> \latest -> EosRes { eosResVersion = osVersionNumber latest pure . JSONResponse $
, eosResHeadline = osVersionHeadline latest mLatest <&> \latest ->
, eosResReleaseNotes = mappedVersions EosRes
} { eosResVersion = osVersionNumber latest
, eosResHeadline = osVersionHeadline latest
, eosResReleaseNotes = mappedVersions
}
getReleaseNotesR :: PkgId -> Handler ReleaseNotes getReleaseNotesR :: PkgId -> Handler ReleaseNotes
getReleaseNotesR pkg = do getReleaseNotesR pkg = do
appConnPool <- appConnPool <$> getYesod appConnPool <- appConnPool <$> getYesod
versionRecords <- runDB $ fetchAllAppVersions appConnPool pkg versionRecords <- runDB $ fetchAllAppVersions appConnPool pkg
pure $ constructReleaseNotesApiRes versionRecords pure $ constructReleaseNotesApiRes versionRecords
where where
constructReleaseNotesApiRes :: [VersionRecord] -> ReleaseNotes constructReleaseNotesApiRes :: [VersionRecord] -> ReleaseNotes
constructReleaseNotesApiRes vers = do constructReleaseNotesApiRes vers = do
ReleaseNotes ReleaseNotes $
$ HM.fromList HM.fromList $
$ sortOn (Down . fst) sortOn (Down . fst) $
$ (versionRecordNumber &&& versionRecordReleaseNotes) (versionRecordNumber &&& versionRecordReleaseNotes)
<$> vers <$> vers
getEosR :: Handler TypedContent getEosR :: Handler TypedContent
getEosR = do getEosR = do
spec <- getVersionSpecFromQuery spec <- getVersionSpecFromQuery
root <- getsYesod $ (</> "eos") . resourcesDir . appSettings root <- getsYesod $ (</> "eos") . resourcesDir . appSettings
subdirs <- listDirectory root subdirs <- listDirectory root
let (failures, successes) = partitionEithers $ Atto.parseOnly parseVersion . T.pack <$> subdirs let (failures, successes) = partitionEithers $ Atto.parseOnly parseVersion . T.pack <$> subdirs
for_ failures $ \f -> $logWarn [i|Emver Parse Failure for EOS: #{f}|] for_ failures $ \f -> $logWarn [i|Emver Parse Failure for EOS: #{f}|]
let mVersion = headMay . sortOn Down . filter (`satisfies` spec) $ successes let mVersion = headMay . sortOn Down . filter (`satisfies` spec) $ successes
case mVersion of case mVersion of
Nothing -> sendResponseStatus status404 (NotFoundE [i|EOS version satisfying #{spec}|]) Nothing -> sendResponseStatus status404 (NotFoundE [i|EOS version satisfying #{spec}|])
Just version -> do Just version -> do
let imgPath = root </> show version </> "eos.img" let imgPath = root </> show version </> "eos.img"
h <- runDB $ retrieveHash version imgPath h <- runDB $ retrieveHash version imgPath
@@ -265,187 +275,32 @@ getEosR = do
retrieveHash v fp = do retrieveHash v fp = do
mHash <- getBy (UniqueVersion v) mHash <- getBy (UniqueVersion v)
case mHash of case mHash of
Just h -> pure . eosHashHash . entityVal $ h Just h -> pure . eosHashHash . entityVal $ h
Nothing -> do Nothing -> do
h <- hashFile @_ @SHA256 fp h <- hashFile @_ @SHA256 fp
let t = decodeUtf8 $ convertToBase Base16 h let t = decodeUtf8 $ convertToBase Base16 h
void $ insertUnique (EosHash v t) -- lazily populate void $ insertUnique (EosHash v t) -- lazily populate
pure t pure t
-- TODO refactor with conduit -- TODO refactor with conduit
getVersionLatestR :: Handler VersionLatestRes getVersionLatestR :: Handler VersionLatestRes
getVersionLatestR = do getVersionLatestR = do
getParameters <- reqGetParams <$> getRequest getParameters <- reqGetParams <$> getRequest
case lookup "ids" getParameters of 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 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 Right p -> do
let packageList = (, Nothing) <$> p let packageList = (,Nothing) <$> p
found <- runDB $ traverse fetchLatestApp $ fst <$> packageList found <- runDB $ traverse fetchLatestApp $ fst <$> packageList
pure pure $
$ VersionLatestRes VersionLatestRes $
$ HM.union HM.union
( HM.fromList ( HM.fromList $
$ (\v -> ( \v ->
(unPkgRecordKey . entityKey $ fst v, Just $ versionRecordNumber $ entityVal $ snd v) (unPkgRecordKey . entityKey $ fst v, Just $ versionRecordNumber $ entityVal $ snd v)
) )
<$> catMaybes found <$> catMaybes found
) )
$ HM.fromList packageList $ 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

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 ) ( i )
import Foundation ( Handler ) import Foundation ( Handler )
import Handler.Types.Status ( AppVersionRes(AppVersionRes) ) import Handler.Types.Status ( AppVersionRes(AppVersionRes) )
import Handler.Util ( orThrow )
import Lib.Error ( S9Error(NotFoundE) ) import Lib.Error ( S9Error(NotFoundE) )
import Lib.PkgRepository ( getBestVersion ) import Lib.PkgRepository ( getBestVersion )
import Lib.Types.AppIndex ( PkgId ) import Lib.Types.AppIndex ( PkgId )
import Network.HTTP.Types.Status ( status404 ) import Network.HTTP.Types.Status ( status404 )
import Util.Shared ( getVersionSpecFromQuery import Util.Shared ( getVersionSpecFromQuery
, orThrow
, versionPriorityFromQueryIsMin , 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 Startlude (
( module X module X,
, module Startlude module Startlude,
) where ) 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 :: a -> a
id = identity id = identity
readMaybe :: Read a => Text -> Maybe a
readMaybe = P.readMaybe . toS readMaybe :: (Read a) => Text -> Maybe a
readMaybe = P.readMaybe
{-# INLINE 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: ./custom-snapshot.yaml
# resolver: https://example.com/snapshots/2018-01-01.yaml # resolver: https://example.com/snapshots/2018-01-01.yaml
resolver: lts-18.11 resolver: nightly-2022-06-06
# User packages to be built. # User packages to be built.
# Various formats can be used as shown in the example below. # Various formats can be used as shown in the example below.
@@ -40,15 +40,14 @@ packages:
# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
# #
extra-deps: extra-deps:
- protolude-0.3.0 - protolude-0.3.1
- esqueleto-3.5.1.0
- monad-logger-extras-0.1.1.1 - monad-logger-extras-0.1.1.1
- persistent-migration-0.3.0 - persistent-migration-0.3.0
- rainbow-0.34.2.2 # - rainbow-0.34.2.2
- terminal-progress-bar-0.4.1 # - terminal-progress-bar-0.4.1
- wai-request-spec-0.10.2.4 # - wai-request-spec-0.10.2.4
- warp-3.3.19 # - warp-3.3.19
- yesod-auth-basic-0.1.0.3 # - yesod-auth-basic-0.1.0.3
# Override default flag values for local packages and extra-deps # Override default flag values for local packages and extra-deps
# flags: {} # flags: {}