From 8b0e8563926469d3346ffbcf6d37be2ff63ab853 Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Wed, 8 Jun 2022 18:30:21 -0600 Subject: [PATCH] wip --- .gitignore | 4 +- Makefile | 2 + config/routes | 20 +- fourmolu.yaml | 8 + package.yaml | 9 +- src/Application.hs | 13 +- src/Database/Marketplace.hs | 336 +++++++------ src/Foundation.hs | 395 ++++++++-------- src/Handler/Admin.hs | 6 +- src/Handler/Apps.hs | 150 +++--- src/Handler/Eos/V0/EosImg.hs | 1 + src/Handler/Eos/V0/Latest.hs | 25 + src/Handler/Icons.hs | 76 +-- src/Handler/Marketplace.hs | 627 ++++++++++--------------- src/Handler/Package.hs | 55 +++ src/Handler/Package/V0/Icon.hs | 32 ++ src/Handler/Package/V0/Index.hs | 278 +++++++++++ src/Handler/Package/V0/Info.hs | 17 + src/Handler/Package/V0/Instructions.hs | 26 + src/Handler/Package/V0/Latest.hs | 17 + src/Handler/Package/V0/License.hs | 21 + src/Handler/Package/V0/Manifest.hs | 1 + src/Handler/Package/V0/ReleaseNotes.hs | 20 + src/Handler/Package/V0/S9PK.hs | 1 + src/Handler/Package/V0/Version.hs | 1 + src/Handler/Types/Api.hs | 29 ++ src/Handler/Types/Marketplace.hs | 163 ------- src/Handler/Util.hs | 83 ++++ src/Handler/Version.hs | 2 +- src/Lib/Conduit.hs | 79 ++++ src/Lib/Ord.hs | 11 + src/Startlude.hs | 58 +-- src/Util/Shared.hs | 171 ------- stack.yaml | 15 +- 34 files changed, 1490 insertions(+), 1262 deletions(-) create mode 100644 fourmolu.yaml create mode 100644 src/Handler/Eos/V0/EosImg.hs create mode 100644 src/Handler/Eos/V0/Latest.hs create mode 100644 src/Handler/Package.hs create mode 100644 src/Handler/Package/V0/Icon.hs create mode 100644 src/Handler/Package/V0/Index.hs create mode 100644 src/Handler/Package/V0/Info.hs create mode 100644 src/Handler/Package/V0/Instructions.hs create mode 100644 src/Handler/Package/V0/Latest.hs create mode 100644 src/Handler/Package/V0/License.hs create mode 100644 src/Handler/Package/V0/Manifest.hs create mode 100644 src/Handler/Package/V0/ReleaseNotes.hs create mode 100644 src/Handler/Package/V0/S9PK.hs create mode 100644 src/Handler/Package/V0/Version.hs create mode 100644 src/Handler/Types/Api.hs delete mode 100644 src/Handler/Types/Marketplace.hs create mode 100644 src/Handler/Util.hs create mode 100644 src/Lib/Conduit.hs create mode 100644 src/Lib/Ord.hs delete mode 100644 src/Util/Shared.hs diff --git a/.gitignore b/.gitignore index 68e722a..dc6cfbf 100644 --- a/.gitignore +++ b/.gitignore @@ -35,4 +35,6 @@ start9-registry.prof start9-registry.hp start9-registry.pdf start9-registry.aux -start9-registry.ps \ No newline at end of file +start9-registry.ps +shell.nix +testdata/ diff --git a/Makefile b/Makefile index 1355b8e..782f76e 100644 --- a/Makefile +++ b/Makefile @@ -1,2 +1,4 @@ all: stack build --local-bin-path dist --copy-bins +profile: + stack build --local-bin-path dist --copy-bins --profile diff --git a/config/routes b/config/routes index 69e33d9..b0580af 100644 --- a/config/routes +++ b/config/routes @@ -3,16 +3,16 @@ /eos/v0/eos.img EosR GET -- get eos.img -- PACKAGE API V0 -/package/v0/info InfoR GET -- get all marketplace categories -/package/v0/index PackageListR GET -- filter marketplace services by various query params -/package/v0/latest VersionLatestR GET -- get latest version of apps in query param id -!/package/v0/#S9PK AppR GET -- get most recent appId at appversion spec, defaults to >=0.0.0 -- ?spec= -/package/v0/manifest/#PkgId AppManifestR GET -- get app manifest from appmgr -- ?spec= -/package/v0/release-notes/#PkgId ReleaseNotesR GET -- get release notes for all versions of a package -/package/v0/icon/#PkgId IconsR GET -- get icons - can specify version with ?spec= -/package/v0/license/#PkgId LicenseR GET -- get license - can specify version with ?spec= -/package/v0/instructions/#PkgId InstructionsR GET -- get instructions - can specify version with ?spec= -/package/v0/version/#PkgId PkgVersionR GET -- get most recent appId version +/package/#ApiVersion/info InfoR GET -- get all marketplace categories +/package/#ApiVersion/index PackageIndexR GET -- filter marketplace services by various query params +/package/#ApiVersion/latest VersionLatestR GET -- get latest version of apps in query param id +!/package/#ApiVersion/#S9PK AppR GET -- get most recent appId at appversion spec, defaults to >=0.0.0 -- ?spec= +/package/#ApiVersion/manifest/#PkgId AppManifestR GET -- get app manifest from appmgr -- ?spec= +/package/#ApiVersion/release-notes/#PkgId ReleaseNotesR GET -- get release notes for all versions of a package +/package/#ApiVersion/icon/#PkgId IconsR GET -- get icons - can specify version with ?spec= +/package/#ApiVersion/license/#PkgId LicenseR GET -- get license - can specify version with ?spec= +/package/#ApiVersion/instructions/#PkgId InstructionsR GET -- get instructions - can specify version with ?spec= +/package/#ApiVersion/version/#PkgId PkgVersionR GET -- get most recent appId version -- SUPPORT API V0 /support/v0/error-logs ErrorLogsR POST diff --git a/fourmolu.yaml b/fourmolu.yaml new file mode 100644 index 0000000..71a5384 --- /dev/null +++ b/fourmolu.yaml @@ -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 diff --git a/package.yaml b/package.yaml index a84dbb2..193d575 100644 --- a/package.yaml +++ b/package.yaml @@ -2,15 +2,10 @@ name: start9-registry version: 0.2.1 default-extensions: - - FlexibleInstances - - GeneralizedNewtypeDeriving - - LambdaCase - - MultiWayIf - - NamedFieldPuns - NoImplicitPrelude - - NumericUnderscores + - GHC2021 + - LambdaCase - OverloadedStrings - - StandaloneDeriving dependencies: - base >=4.12 && <5 diff --git a/src/Application.hs b/src/Application.hs index 929c2e1..3787dd1 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -165,22 +165,11 @@ import Handler.Admin ( deleteCategoryR , postPkgIndexR , postPkgUploadR ) -import Handler.Apps ( getAppManifestR - , getAppR - ) import Handler.ErrorLogs ( postErrorLogsR ) -import Handler.Icons ( getIconsR - , getInstructionsR - , getLicenseR - ) import Handler.Marketplace ( getEosR , getEosVersionR - , getInfoR - , getPackageListR - , getReleaseNotesR - , getVersionLatestR ) -import Handler.Version ( getPkgVersionR ) +import Handler.Package import Lib.PkgRepository ( watchEosRepoRoot ) import Lib.Ssl ( doesSslNeedRenew , renewSslCerts diff --git a/src/Database/Marketplace.hs b/src/Database/Marketplace.hs index 6a4320c..25d5f2f 100644 --- a/src/Database/Marketplace.hs +++ b/src/Database/Marketplace.hs @@ -1,107 +1,127 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + {-# HLINT ignore "Fuse on/on" #-} module Database.Marketplace where -import Conduit ( ConduitT - , MonadResource - , MonadUnliftIO - , awaitForever - , leftover - , yield - ) -import Control.Monad.Loops ( unfoldM ) -import Data.Conduit ( await ) -import Database.Esqueleto.Experimental - ( (%) - , (&&.) - , (++.) - , (:&)(..) - , (==.) - , (^.) - , asc - , desc - , from - , groupBy - , ilike - , in_ - , innerJoin - , on - , orderBy - , select - , selectSource - , table - , val - , valList - , where_ - , (||.) - ) -import qualified Database.Persist as P -import Database.Persist.Postgresql ( ConnectionPool - , Entity(entityKey, entityVal) - , PersistEntity(Key) - , SqlBackend - , runSqlPool - ) -import Handler.Types.Marketplace ( PackageDependencyMetadata(..) ) -import Lib.Types.AppIndex ( PkgId ) -import Lib.Types.Emver ( Version ) -import Model ( Category - , EntityField - ( CategoryId - , CategoryName - , PkgCategoryCategoryId - , PkgCategoryPkgId - , PkgDependencyDepId - , PkgDependencyPkgId - , PkgDependencyPkgVersion - , PkgRecordId - , VersionRecordDescLong - , VersionRecordDescShort - , VersionRecordNumber - , VersionRecordPkgId - , VersionRecordTitle - , VersionRecordUpdatedAt - ) - , Key(PkgRecordKey, unPkgRecordKey) - , PkgCategory - , PkgDependency - , PkgRecord - , VersionRecord(versionRecordNumber, versionRecordPkgId) - ) -import Startlude ( ($) - , ($>) - , (.) - , (<$>) - , Applicative(pure) - , Down(Down) - , Eq((==)) - , Functor(fmap) - , Maybe(..) - , Monad - , MonadIO - , ReaderT - , Text - , headMay - , lift - , snd - , sortOn - ) +import Conduit ( + ConduitT, + MonadResource, + MonadUnliftIO, + awaitForever, + leftover, + yield, + ) +import Control.Monad.Loops (unfoldM) +import Data.Conduit (await) +import Database.Esqueleto.Experimental ( + asc, + desc, + from, + groupBy, + ilike, + in_, + innerJoin, + on, + orderBy, + select, + selectSource, + table, + val, + valList, + where_, + (%), + (&&.), + (++.), + (:&) (..), + (==.), + (^.), + (||.), + ) +import Database.Persist qualified as P +import Database.Persist.Postgresql ( + ConnectionPool, + Entity (entityKey, entityVal), + PersistEntity (Key), + SqlBackend, + runSqlPool, + ) +import Lib.Types.AppIndex (PkgId) +import Lib.Types.Emver (Version) +import Model ( + Category, + EntityField ( + CategoryId, + CategoryName, + PkgCategoryCategoryId, + PkgCategoryPkgId, + PkgDependencyDepId, + PkgDependencyPkgId, + PkgDependencyPkgVersion, + PkgRecordId, + VersionRecordDescLong, + VersionRecordDescShort, + VersionRecordNumber, + VersionRecordPkgId, + VersionRecordTitle, + VersionRecordUpdatedAt + ), + Key (PkgRecordKey, unPkgRecordKey), + PkgCategory, + PkgDependency, + PkgRecord, + VersionRecord (versionRecordNumber, versionRecordPkgId), + ) +import Startlude ( + Applicative (pure), + Down (Down), + Eq ((==)), + Functor (fmap), + Maybe (..), + Monad, + MonadIO, + ReaderT, + Show, + Text, + headMay, + lift, + snd, + sortOn, + ($), + ($>), + (.), + (<$>), + ) -type CategoryTitle = Text -searchServices :: (MonadResource m, MonadIO m) - => Maybe CategoryTitle - -> Text - -> ConduitT () (Entity VersionRecord) (ReaderT SqlBackend m) () +data PackageMetadata = PackageMetadata + { packageMetadataPkgId :: !PkgId + , packageMetadataPkgVersionRecords :: ![Entity VersionRecord] + , packageMetadataPkgCategories :: ![Entity Category] + , packageMetadataPkgVersion :: !Version + } + deriving (Eq, Show) +data PackageDependencyMetadata = PackageDependencyMetadata + { packageDependencyMetadataPkgDependencyRecord :: !(Entity PkgDependency) + , packageDependencyMetadataDepPkgRecord :: !(Entity PkgRecord) + , packageDependencyMetadataDepVersions :: ![Entity VersionRecord] + } + deriving (Eq, Show) + + +searchServices :: + (MonadResource m, MonadIO m) => + Maybe Text -> + Text -> + ConduitT () (Entity VersionRecord) (ReaderT SqlBackend m) () searchServices Nothing query = selectSource $ do service <- from $ table @VersionRecord where_ - ( (service ^. VersionRecordDescShort `ilike` (%) ++. val query ++. (%)) - ||. (service ^. VersionRecordDescLong `ilike` (%) ++. val query ++. (%)) - ||. (service ^. VersionRecordTitle `ilike` (%) ++. val query ++. (%)) + ( (service ^. VersionRecordDescShort `ilike` (%) ++. val query ++. (%)) + ||. (service ^. VersionRecordDescLong `ilike` (%) ++. val query ++. (%)) + ||. (service ^. VersionRecordTitle `ilike` (%) ++. val query ++. (%)) ) groupBy (service ^. VersionRecordPkgId, service ^. VersionRecordNumber) orderBy @@ -111,27 +131,28 @@ searchServices Nothing query = selectSource $ do ] pure service searchServices (Just category) query = selectSource $ do - services <- from - (do - (service :& _ :& cat) <- - from - $ table @VersionRecord - `innerJoin` table @PkgCategory - `on` (\(s :& sc) -> sc ^. PkgCategoryPkgId ==. s ^. VersionRecordPkgId) - `innerJoin` table @Category - `on` (\(_ :& sc :& cat) -> sc ^. PkgCategoryCategoryId ==. cat ^. CategoryId) - -- if there is a cateogry, only search in category - -- weight title, short, long (bitcoin should equal Bitcoin Core) - where_ - $ cat - ^. CategoryName - ==. val category - &&. ( (service ^. VersionRecordDescShort `ilike` (%) ++. val query ++. (%)) - ||. (service ^. VersionRecordDescLong `ilike` (%) ++. val query ++. (%)) - ||. (service ^. VersionRecordTitle `ilike` (%) ++. val query ++. (%)) - ) - pure service - ) + services <- + from + ( do + (service :& _ :& cat) <- + from $ + table @VersionRecord + `innerJoin` table @PkgCategory + `on` (\(s :& sc) -> sc ^. PkgCategoryPkgId ==. s ^. VersionRecordPkgId) + `innerJoin` table @Category + `on` (\(_ :& sc :& cat) -> sc ^. PkgCategoryCategoryId ==. cat ^. CategoryId) + -- if there is a cateogry, only search in category + -- weight title, short, long (bitcoin should equal Bitcoin Core) + where_ $ + cat + ^. CategoryName + ==. val category + &&. ( (service ^. VersionRecordDescShort `ilike` (%) ++. val query ++. (%)) + ||. (service ^. VersionRecordDescLong `ilike` (%) ++. val query ++. (%)) + ||. (service ^. VersionRecordTitle `ilike` (%) ++. val query ++. (%)) + ) + pure service + ) groupBy (services ^. VersionRecordPkgId, services ^. VersionRecordNumber) orderBy [ asc (services ^. VersionRecordPkgId) @@ -140,48 +161,56 @@ searchServices (Just category) query = selectSource $ do ] pure services + getPkgData :: (MonadResource m, MonadIO m) => [PkgId] -> ConduitT () (Entity VersionRecord) (ReaderT SqlBackend m) () getPkgData pkgs = selectSource $ do pkgData <- from $ table @VersionRecord where_ (pkgData ^. VersionRecordPkgId `in_` valList (PkgRecordKey <$> pkgs)) pure pkgData -getPkgDependencyData :: MonadIO m - => Key PkgRecord - -> Version - -> ReaderT SqlBackend m [(Entity PkgDependency, Entity PkgRecord)] + +getPkgDependencyData :: + MonadIO m => + Key PkgRecord -> + Version -> + ReaderT SqlBackend m [(Entity PkgDependency, Entity PkgRecord)] getPkgDependencyData pkgId pkgVersion = select $ do from - (do + ( do (pkgDepRecord :& depPkgRecord) <- - from - $ table @PkgDependency - `innerJoin` table @PkgRecord - `on` (\(pdr :& dpr) -> dpr ^. PkgRecordId ==. pdr ^. PkgDependencyDepId) + from $ + table @PkgDependency + `innerJoin` table @PkgRecord + `on` (\(pdr :& dpr) -> dpr ^. PkgRecordId ==. pdr ^. PkgDependencyDepId) where_ (pkgDepRecord ^. PkgDependencyPkgId ==. val pkgId) where_ (pkgDepRecord ^. PkgDependencyPkgVersion ==. val pkgVersion) pure (pkgDepRecord, depPkgRecord) ) -zipCategories :: MonadUnliftIO m - => ConduitT - (PkgId, [Entity VersionRecord]) - (PkgId, [Entity VersionRecord], [Entity Category]) - (ReaderT SqlBackend m) - () + +zipCategories :: + MonadUnliftIO m => + ConduitT + (PkgId, [Entity VersionRecord]) + (PkgId, [Entity VersionRecord], [Entity Category]) + (ReaderT SqlBackend m) + () zipCategories = awaitForever $ \(pkg, vers) -> do - raw <- lift $ select $ do - (sc :& cat) <- - from - $ table @PkgCategory - `innerJoin` table @Category - `on` (\(sc :& cat) -> sc ^. PkgCategoryCategoryId ==. cat ^. CategoryId) - where_ (sc ^. PkgCategoryPkgId ==. val (PkgRecordKey pkg)) - pure cat + raw <- lift $ + select $ do + (sc :& cat) <- + from $ + table @PkgCategory + `innerJoin` table @Category + `on` (\(sc :& cat) -> sc ^. PkgCategoryCategoryId ==. cat ^. CategoryId) + where_ (sc ^. PkgCategoryPkgId ==. val (PkgRecordKey pkg)) + pure cat yield (pkg, vers, raw) -collateVersions :: MonadUnliftIO m - => ConduitT (Entity VersionRecord) (PkgId, [Entity VersionRecord]) (ReaderT SqlBackend m) () + +collateVersions :: + MonadUnliftIO m => + ConduitT (Entity VersionRecord) (PkgId, [Entity VersionRecord]) (ReaderT SqlBackend m) () collateVersions = awaitForever $ \v0 -> do let pkg = unPkgRecordKey . versionRecordPkgId $ entityVal v0 let pull = do @@ -194,32 +223,39 @@ collateVersions = awaitForever $ \v0 -> do ls <- unfoldM pull yield (pkg, v0 : ls) -zipDependencyVersions :: (Monad m, MonadIO m) - => (Entity PkgDependency, Entity PkgRecord) - -> ReaderT SqlBackend m PackageDependencyMetadata + +zipDependencyVersions :: + (Monad m, MonadIO m) => + (Entity PkgDependency, Entity PkgRecord) -> + ReaderT SqlBackend m PackageDependencyMetadata zipDependencyVersions (pkgDepRecord, depRecord) = do let pkgDbId = entityKey depRecord depVers <- select $ do v <- from $ table @VersionRecord where_ $ v ^. VersionRecordPkgId ==. val pkgDbId pure v - pure $ PackageDependencyMetadata { packageDependencyMetadataPkgDependencyRecord = pkgDepRecord - , packageDependencyMetadataDepPkgRecord = depRecord - , packageDependencyMetadataDepVersions = depVers - } + pure $ + PackageDependencyMetadata + { packageDependencyMetadataPkgDependencyRecord = pkgDepRecord + , packageDependencyMetadataDepPkgRecord = depRecord + , packageDependencyMetadataDepVersions = depVers + } + fetchAllAppVersions :: MonadUnliftIO m => ConnectionPool -> PkgId -> m [VersionRecord] fetchAllAppVersions appConnPool appId = do entityAppVersions <- runSqlPool (P.selectList [VersionRecordPkgId P.==. PkgRecordKey appId] []) appConnPool pure $ entityVal <$> entityAppVersions + fetchLatestApp :: MonadIO m => PkgId -> ReaderT SqlBackend m (Maybe (P.Entity PkgRecord, P.Entity VersionRecord)) fetchLatestApp appId = fmap headMay . sortResults . select $ do (service :& version) <- - from - $ table @PkgRecord - `innerJoin` table @VersionRecord - `on` (\(service :& version) -> service ^. PkgRecordId ==. version ^. VersionRecordPkgId) + from $ + table @PkgRecord + `innerJoin` table @VersionRecord + `on` (\(service :& version) -> service ^. PkgRecordId ==. version ^. VersionRecordPkgId) where_ (service ^. PkgRecordId ==. val (PkgRecordKey appId)) pure (service, version) - where sortResults = fmap $ sortOn (Down . versionRecordNumber . entityVal . snd) + where + sortResults = fmap $ sortOn (Down . versionRecordNumber . entityVal . snd) diff --git a/src/Foundation.hs b/src/Foundation.hs index a01ed67..53b6eac 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1,184 +1,203 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -Wno-orphans #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-orphans #-} module Foundation where -import Startlude ( ($) - , (.) - , (<$>) - , (<&>) - , (<**>) - , (=<<) - , Applicative(pure) - , Bool(False) - , Eq((==)) - , IO - , MVar - , Maybe(..) - , Monad(return) - , Monoid(mempty) - , Semigroup((<>)) - , String - , Text - , ThreadId - , Word64 - , decodeUtf8 - , drop - , encodeUtf8 - , flip - , fst - , isJust - , otherwise - , putMVar - , show - , when - , (||) - ) +import Startlude ( + Applicative (pure), + Bool (False), + Eq ((==)), + IO, + MVar, + Maybe (..), + Monad (return), + Monoid (mempty), + Semigroup ((<>)), + String, + Text, + ThreadId, + Word64, + decodeUtf8, + drop, + encodeUtf8, + flip, + fst, + isJust, + otherwise, + putMVar, + show, + when, + ($), + (.), + (<$>), + (<&>), + (<**>), + (=<<), + (||), + ) -import Control.Monad.Logger ( Loc - , LogSource - , LogStr - , ToLogStr(toLogStr) - , fromLogStr - ) -import Database.Persist.Sql ( ConnectionPool - , LogFunc - , PersistStoreRead(get) - , SqlBackend - , SqlPersistT - , runSqlPool - ) -import Lib.Registry ( S9PK ) -import Yesod.Core ( AuthResult(Authorized, Unauthorized) - , LogLevel(..) - , MonadHandler(liftHandler) - , RenderMessage(..) - , RenderRoute(Route, renderRoute) - , RouteAttrs(routeAttrs) - , SessionBackend - , ToTypedContent - , Yesod - ( isAuthorized - , makeLogger - , makeSessionBackend - , maximumContentLengthIO - , messageLoggerSource - , shouldLogIO - , yesodMiddleware - ) - , defaultYesodMiddleware - , getYesod - , getsYesod - , mkYesodData - , parseRoutesFile - ) -import Yesod.Core.Types ( HandlerData(handlerEnv) - , Logger(loggerDate) - , RunHandlerEnv(rheChild, rheSite) - , loggerPutStr - ) -import qualified Yesod.Core.Unsafe as Unsafe +import Control.Monad.Logger ( + Loc, + LogSource, + LogStr, + ToLogStr (toLogStr), + fromLogStr, + ) +import Database.Persist.Sql ( + ConnectionPool, + LogFunc, + PersistStoreRead (get), + SqlBackend, + SqlPersistT, + runSqlPool, + ) +import Lib.Registry (S9PK) +import Yesod.Core ( + AuthResult (Authorized, Unauthorized), + LogLevel (..), + MonadHandler (liftHandler), + RenderMessage (..), + RenderRoute (Route, renderRoute), + RouteAttrs (routeAttrs), + SessionBackend, + ToTypedContent, + Yesod ( + isAuthorized, + makeLogger, + makeSessionBackend, + maximumContentLengthIO, + messageLoggerSource, + shouldLogIO, + yesodMiddleware + ), + defaultYesodMiddleware, + getYesod, + getsYesod, + mkYesodData, + parseRoutesFile, + ) +import Yesod.Core.Types ( + HandlerData (handlerEnv), + Logger (loggerDate), + RunHandlerEnv (rheChild, rheSite), + loggerPutStr, + ) +import Yesod.Core.Unsafe qualified as Unsafe + +import Control.Monad.Logger.Extras (wrapSGRCode) +import Control.Monad.Reader.Has (Has (extract, update)) +import Crypto.Hash ( + SHA256 (SHA256), + hashWith, + ) +import Data.Set (member) +import Data.String.Interpolate.IsString ( + i, + ) +import Data.Text qualified as T +import Handler.Types.Api (ApiVersion (..)) +import Language.Haskell.TH (Loc (..)) +import Lib.PkgRepository ( + EosRepo, + PkgRepo, + ) +import Lib.Types.AppIndex (PkgId) +import Model ( + Admin (..), + Key (AdminKey), + ) +import Settings (AppSettings (appShouldLogAll)) +import System.Console.ANSI.Codes ( + Color (..), + ColorIntensity (..), + ConsoleLayer (Foreground), + SGR (SetColor), + ) +import Yesod ( + FormMessage, + defaultFormMessage, + ) +import Yesod.Auth ( + AuthEntity, + Creds (credsIdent), + YesodAuth ( + AuthId, + authPlugins, + getAuthId, + loginDest, + logoutDest, + maybeAuthId + ), + YesodAuthPersist (getAuthEntity), + ) +import Yesod.Auth.Http.Basic ( + defaultAuthSettings, + defaultMaybeBasicAuthId, + ) +import Yesod.Persist.Core ( + DBRunner, + YesodPersist (..), + YesodPersistRunner (..), + defaultGetDBRunner, + ) -import Control.Monad.Logger.Extras ( wrapSGRCode ) -import Control.Monad.Reader.Has ( Has(extract, update) ) -import Crypto.Hash ( SHA256(SHA256) - , hashWith - ) -import Data.Set ( member ) -import Data.String.Interpolate.IsString - ( i ) -import qualified Data.Text as T -import Language.Haskell.TH ( Loc(..) ) -import Lib.PkgRepository ( EosRepo - , PkgRepo - ) -import Lib.Types.AppIndex ( PkgId ) -import Model ( Admin(..) - , Key(AdminKey) - ) -import Settings ( AppSettings(appShouldLogAll) ) -import System.Console.ANSI.Codes ( Color(..) - , ColorIntensity(..) - , ConsoleLayer(Foreground) - , SGR(SetColor) - ) -import Yesod ( FormMessage - , defaultFormMessage - ) -import Yesod.Auth ( AuthEntity - , Creds(credsIdent) - , YesodAuth - ( AuthId - , authPlugins - , getAuthId - , loginDest - , logoutDest - , maybeAuthId - ) - , YesodAuthPersist(getAuthEntity) - ) -import Yesod.Auth.Http.Basic ( defaultAuthSettings - , defaultMaybeBasicAuthId - ) -import Yesod.Persist.Core ( DBRunner - , YesodPersist(..) - , YesodPersistRunner(..) - , defaultGetDBRunner - ) -- | The foundation datatype for your application. This can be a good place to -- keep settings and values requiring initialization before your application -- starts running, such as database connections. Every handler will have -- access to the data present here. - - data RegistryCtx = RegistryCtx - { appSettings :: AppSettings - , appLogger :: Logger + { appSettings :: AppSettings + , appLogger :: Logger , appWebServerThreadId :: MVar (ThreadId, ThreadId) - , appShouldRestartWeb :: MVar Bool - , appConnPool :: ConnectionPool - , appStopFsNotifyEos :: IO Bool + , appShouldRestartWeb :: MVar Bool + , appConnPool :: ConnectionPool + , appStopFsNotifyEos :: IO Bool } + + instance Has PkgRepo RegistryCtx where extract = transitiveExtract @AppSettings - update = transitiveUpdate @AppSettings + update = transitiveUpdate @AppSettings instance Has a r => Has a (HandlerData r r) where extract = extract . rheSite . handlerEnv update f r = let ctx = update f (rheSite $ handlerEnv r) - rhe = (handlerEnv r) { rheSite = ctx, rheChild = ctx } - in r { handlerEnv = rhe } + rhe = (handlerEnv r){rheSite = ctx, rheChild = ctx} + in r{handlerEnv = rhe} instance Has AppSettings RegistryCtx where extract = appSettings - update f ctx = ctx { appSettings = f (appSettings ctx) } + update f ctx = ctx{appSettings = f (appSettings ctx)} instance Has EosRepo RegistryCtx where extract = transitiveExtract @AppSettings - update = transitiveUpdate @AppSettings + update = transitiveUpdate @AppSettings + {-# INLINE transitiveExtract #-} -transitiveExtract :: forall b a c . (Has a b, Has b c) => c -> a +transitiveExtract :: forall b a c. (Has a b, Has b c) => c -> a transitiveExtract = extract @a . extract @b + {-# INLINE transitiveUpdate #-} -transitiveUpdate :: forall b a c . (Has a b, Has b c) => (a -> a) -> (c -> c) +transitiveUpdate :: forall b a c. (Has a b, Has b c) => (a -> a) -> (c -> c) transitiveUpdate f = update (update @a @b f) setWebProcessThreadId :: (ThreadId, ThreadId) -> RegistryCtx -> IO () setWebProcessThreadId tid@(!_, !_) a = putMVar (appWebServerThreadId a) tid + -- This is where we define all of the routes in our application. For a full -- explanation of the syntax, please see: -- http://www.yesodweb.com/book/routing-and-handlers @@ -193,68 +212,73 @@ setWebProcessThreadId tid@(!_, !_) a = putMVar (appWebServerThreadId a) tid -- type Handler = HandlerT RegistryCtx IO mkYesodData "RegistryCtx" $(parseRoutesFile "config/routes") + -- Please see the documentation for the Yesod typeclass. There are a number -- of settings which can be configured by overriding methods here. instance Yesod RegistryCtx where - --- Store session data on the client in encrypted cookies, --- default session idle timeout is 120 minutes + -- Store session data on the client in encrypted cookies, + -- default session idle timeout is 120 minutes makeSessionBackend :: RegistryCtx -> IO (Maybe SessionBackend) makeSessionBackend _ = pure Nothing --- Yesod Middleware allows you to run code before and after each handler function. --- The defaultYesodMiddleware adds the response header "Vary: Accept, Accept-Language" and performs authorization checks. --- Some users may also want to add the defaultCsrfMiddleware, which: --- a) Sets a cookie with a CSRF token in it. --- b) Validates that incoming write requests include that token in either a header or POST parameter. --- To add it, chain it together with the defaultMiddleware: yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware --- For details, see the CSRF documentation in the Yesod.Core.Handler module of the yesod-core package. + + -- Yesod Middleware allows you to run code before and after each handler function. + -- The defaultYesodMiddleware adds the response header "Vary: Accept, Accept-Language" and performs authorization checks. + -- Some users may also want to add the defaultCsrfMiddleware, which: + -- a) Sets a cookie with a CSRF token in it. + -- b) Validates that incoming write requests include that token in either a header or POST parameter. + -- To add it, chain it together with the defaultMiddleware: yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware + -- For details, see the CSRF documentation in the Yesod.Core.Handler module of the yesod-core package. yesodMiddleware :: ToTypedContent res => Handler res -> Handler res yesodMiddleware = defaultYesodMiddleware --- What messages should be logged. The following includes all messages when --- in development, and warnings and errors in production. + + -- What messages should be logged. The following includes all messages when + -- in development, and warnings and errors in production. shouldLogIO :: RegistryCtx -> LogSource -> LogLevel -> IO Bool shouldLogIO app _source level = return $ appShouldLogAll (appSettings app) || level == LevelInfo || level == LevelWarn || level == LevelError + makeLogger :: RegistryCtx -> IO Logger makeLogger = return . appLogger + messageLoggerSource :: RegistryCtx -> Logger -> Loc -> LogSource -> LogLevel -> LogStr -> IO () messageLoggerSource ctx logger = \loc src lvl str -> do shouldLog <- shouldLogIO ctx src lvl when shouldLog $ do date <- loggerDate logger - let - formatted = + let formatted = toLogStr date <> ( toLogStr - . wrapSGRCode [SetColor Foreground Vivid (colorFor lvl)] - $ fromLogStr - ( " [" - <> renderLvl lvl - <> (if T.null src then mempty else "#" <> toLogStr src) - <> "] " - <> str - ) + . wrapSGRCode [SetColor Foreground Vivid (colorFor lvl)] + $ fromLogStr + ( " [" + <> renderLvl lvl + <> (if T.null src then mempty else "#" <> toLogStr src) + <> "] " + <> str + ) ) <> toLogStr - (wrapSGRCode [SetColor Foreground Dull White] - [i| @ #{loc_filename loc}:#{fst $ loc_start loc}\n|] - ) + ( wrapSGRCode + [SetColor Foreground Dull White] + [i| @ #{loc_filename loc}:#{fst $ loc_start loc}\n|] + ) loggerPutStr logger formatted where renderLvl lvl = case lvl of LevelOther t -> toLogStr t - _ -> toLogStr @String $ drop 5 $ show lvl + _ -> toLogStr @String $ drop 5 $ show lvl colorFor = \case - LevelDebug -> Green - LevelInfo -> Blue - LevelWarn -> Yellow - LevelError -> Red + LevelDebug -> Green + LevelInfo -> Blue + LevelWarn -> Yellow + LevelError -> Red LevelOther _ -> White + isAuthorized :: Route RegistryCtx -> Bool -> Handler AuthResult isAuthorized route _ | "admin" `member` routeAttrs route = do @@ -262,9 +286,11 @@ instance Yesod RegistryCtx where pure $ if hasAuthId then Authorized else Unauthorized "This feature is for admins only" | otherwise = pure Authorized + maximumContentLengthIO :: RegistryCtx -> Maybe (Route RegistryCtx) -> IO (Maybe Word64) maximumContentLengthIO _ (Just PkgUploadR) = pure Nothing - maximumContentLengthIO _ _ = pure $ Just 2097152 -- the original default + maximumContentLengthIO _ _ = pure $ Just 2097152 -- the original default + -- How to run database actions. instance YesodPersist RegistryCtx where @@ -272,37 +298,40 @@ instance YesodPersist RegistryCtx where runDB :: SqlPersistT Handler a -> Handler a runDB action = runSqlPool action . appConnPool =<< getYesod + instance YesodPersistRunner RegistryCtx where getDBRunner :: Handler (DBRunner RegistryCtx, Handler ()) getDBRunner = defaultGetDBRunner appConnPool + instance RenderMessage RegistryCtx FormMessage where renderMessage _ _ = defaultFormMessage instance YesodAuth RegistryCtx where type AuthId RegistryCtx = Text - getAuthId = pure . Just . credsIdent + getAuthId = pure . Just . credsIdent maybeAuthId = do pool <- getsYesod appConnPool let checkCreds k s = flip runSqlPool pool $ do let passHash = hashWith SHA256 . encodeUtf8 . ("start9_admin:" <>) $ decodeUtf8 s get (AdminKey $ decodeUtf8 k) <&> \case - Nothing -> False - Just Admin { adminPassHash } -> adminPassHash == passHash + Nothing -> False + Just Admin{adminPassHash} -> adminPassHash == passHash defaultMaybeBasicAuthId checkCreds defaultAuthSettings - loginDest _ = PackageListR - logoutDest _ = PackageListR + loginDest _ = PackageIndexR V1 + logoutDest _ = PackageIndexR V1 authPlugins _ = [] + instance YesodAuthPersist RegistryCtx where type AuthEntity RegistryCtx = Admin getAuthEntity = liftHandler . runDB . get . AdminKey - unsafeHandler :: RegistryCtx -> Handler a -> IO a unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger + -- Note: Some functionality previously present in the scaffolding has been -- moved to documentation in the Wiki. Following are some hopefully helpful -- links: diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 971f428..813055a 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -43,6 +43,9 @@ import Database.Queries ( upsertPackageVersion ) import Foundation ( Handler , RegistryCtx(..) ) +import Handler.Util ( orThrow + , sendResponseText + ) import Lib.PkgRepository ( PkgRepo(PkgRepo, pkgRepoFileRoot) , extractPkg , getManifestLocation @@ -110,9 +113,6 @@ import UnliftIO.Directory ( createDirectoryIfMissing , renameDirectory , renameFile ) -import Util.Shared ( orThrow - , sendResponseText - ) import Yesod ( ToJSON(..) , delete , getsYesod diff --git a/src/Handler/Apps.hs b/src/Handler/Apps.hs index 187da10..c51d72e 100644 --- a/src/Handler/Apps.hs +++ b/src/Handler/Apps.hs @@ -1,98 +1,107 @@ -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} module Handler.Apps where -import Startlude ( ($) - , (.) - , Applicative(pure) - , FilePath - , Maybe(..) - , Monad((>>=)) - , Show - , String - , show - , void - ) +import Startlude ( + Applicative (pure), + FilePath, + Maybe (..), + Monad ((>>=)), + Show, + String, + show, + void, + ($), + (.), + ) -import Control.Monad.Logger ( logError ) -import qualified Data.Text as T -import qualified GHC.Show ( Show(..) ) -import Network.HTTP.Types ( status404 ) -import System.FilePath ( (<.>) - , takeBaseName - ) -import Yesod.Core ( Content(ContentFile) - , TypedContent - , addHeader - , notFound - , respond - , respondSource - , sendChunkBS - , sendResponseStatus - , typeJson - , typeOctet - ) -import Yesod.Persist.Core ( YesodPersist(runDB) ) +import Control.Monad.Logger (logError) +import Data.Text qualified as T +import GHC.Show qualified (Show (..)) +import Network.HTTP.Types (status404) +import System.FilePath ( + takeBaseName, + (<.>), + ) +import Yesod.Core ( + Content (ContentFile), + TypedContent, + addHeader, + notFound, + respond, + respondSource, + sendChunkBS, + sendResponseStatus, + typeJson, + typeOctet, + ) +import Yesod.Persist.Core (YesodPersist (runDB)) + +import Conduit ( + awaitForever, + (.|), + ) +import Data.String.Interpolate.IsString ( + i, + ) +import Database.Queries ( + createMetric, + fetchApp, + fetchAppVersion, + ) +import Foundation (Handler) +import Handler.Util (addPackageHeader, getVersionSpecFromQuery, orThrow, versionPriorityFromQueryIsMin) +import Lib.Error (S9Error (NotFoundE)) +import Lib.PkgRepository ( + getBestVersion, + getManifest, + getPackage, + ) +import Lib.Registry (S9PK) +import Lib.Types.AppIndex (PkgId (PkgId)) +import Lib.Types.Emver (Version) -import Conduit ( (.|) - , awaitForever - ) -import Data.String.Interpolate.IsString - ( i ) -import Database.Queries ( createMetric - , fetchApp - , fetchAppVersion - ) -import Foundation ( Handler ) -import Lib.Error ( S9Error(NotFoundE) ) -import Lib.PkgRepository ( getBestVersion - , getManifest - , getPackage - ) -import Lib.Registry ( S9PK ) -import Lib.Types.AppIndex ( PkgId(PkgId) ) -import Lib.Types.Emver ( Version ) -import Util.Shared ( addPackageHeader - , getVersionSpecFromQuery - , orThrow - , versionPriorityFromQueryIsMin - ) data FileExtension = FileExtension !FilePath !(Maybe String) instance Show FileExtension where - show (FileExtension f Nothing ) = f + show (FileExtension f Nothing) = f show (FileExtension f (Just e)) = f <.> e + getAppManifestR :: PkgId -> Handler TypedContent getAppManifestR pkg = do versionSpec <- getVersionSpecFromQuery - preferMin <- versionPriorityFromQueryIsMin - version <- getBestVersion pkg versionSpec preferMin - `orThrow` sendResponseStatus status404 (NotFoundE [i|#{pkg} satisfying #{versionSpec}|]) + preferMin <- versionPriorityFromQueryIsMin + version <- + getBestVersion pkg versionSpec preferMin + `orThrow` sendResponseStatus status404 (NotFoundE [i|#{pkg} satisfying #{versionSpec}|]) addPackageHeader pkg version (len, src) <- getManifest pkg version addHeader "Content-Length" (show len) respondSource typeJson $ src .| awaitForever sendChunkBS + getAppR :: S9PK -> Handler TypedContent getAppR file = do let pkg = PkgId . T.pack $ takeBaseName (show file) versionSpec <- getVersionSpecFromQuery - preferMin <- versionPriorityFromQueryIsMin - version <- getBestVersion pkg versionSpec preferMin - `orThrow` sendResponseStatus status404 (NotFoundE [i|#{pkg} satisfying #{versionSpec}|]) + preferMin <- versionPriorityFromQueryIsMin + version <- + getBestVersion pkg versionSpec preferMin + `orThrow` sendResponseStatus status404 (NotFoundE [i|#{pkg} satisfying #{versionSpec}|]) addPackageHeader pkg version void $ recordMetrics pkg version - pkgPath <- getPackage pkg version >>= \case - Nothing -> sendResponseStatus status404 (NotFoundE [i|#{pkg}@#{version}|]) - Just a -> pure a + pkgPath <- + getPackage pkg version >>= \case + Nothing -> sendResponseStatus status404 (NotFoundE [i|#{pkg}@#{version}|]) + Just a -> pure a respond typeOctet $ ContentFile pkgPath Nothing @@ -110,4 +119,3 @@ recordMetrics pkg appVersion = do $logError [i|#{pkg}@#{appVersion} not found in database|] notFound Just _ -> runDB $ createMetric pkg appVersion - diff --git a/src/Handler/Eos/V0/EosImg.hs b/src/Handler/Eos/V0/EosImg.hs new file mode 100644 index 0000000..833244c --- /dev/null +++ b/src/Handler/Eos/V0/EosImg.hs @@ -0,0 +1 @@ +module Handler.Eos.V0.EosImg where diff --git a/src/Handler/Eos/V0/Latest.hs b/src/Handler/Eos/V0/Latest.hs new file mode 100644 index 0000000..5612e7a --- /dev/null +++ b/src/Handler/Eos/V0/Latest.hs @@ -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 \ No newline at end of file diff --git a/src/Handler/Icons.hs b/src/Handler/Icons.hs index 3369d03..dacff3a 100644 --- a/src/Handler/Icons.hs +++ b/src/Handler/Icons.hs @@ -1,80 +1,18 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} module Handler.Icons where -import Startlude ( ($) - , Eq - , Generic - , Read - , Show - , show - ) +import Data.Aeson (FromJSON, ToJSON) +import Startlude (Eq, Generic, Read, Show) -import Data.Conduit ( (.|) - , awaitForever - ) -import Data.String.Interpolate.IsString - ( i ) -import Foundation ( Handler ) -import Lib.Error ( S9Error(NotFoundE) ) -import Lib.PkgRepository ( getBestVersion - , getIcon - , getInstructions - , getLicense - ) -import Lib.Types.AppIndex ( PkgId ) -import Network.HTTP.Types ( status400 ) -import Util.Shared ( getVersionSpecFromQuery - , orThrow - , versionPriorityFromQueryIsMin - ) -import Yesod.Core ( FromJSON - , ToJSON - , TypedContent - , addHeader - , respondSource - , sendChunkBS - , sendResponseStatus - , typePlain - ) data IconType = PNG | JPG | JPEG | SVG deriving (Eq, Show, Generic, Read) instance ToJSON IconType instance FromJSON IconType - -getIconsR :: PkgId -> Handler TypedContent -getIconsR pkg = do - spec <- getVersionSpecFromQuery - preferMin <- versionPriorityFromQueryIsMin - version <- getBestVersion pkg spec preferMin - `orThrow` sendResponseStatus status400 (NotFoundE [i|Icon for #{pkg} satisfying #{spec}|]) - (ct, len, src) <- getIcon pkg version - addHeader "Content-Length" (show len) - respondSource ct $ src .| awaitForever sendChunkBS - -getLicenseR :: PkgId -> Handler TypedContent -getLicenseR pkg = do - spec <- getVersionSpecFromQuery - preferMin <- versionPriorityFromQueryIsMin - version <- getBestVersion pkg spec preferMin - `orThrow` sendResponseStatus status400 (NotFoundE [i|License for #{pkg} satisfying #{spec}|]) - (len, src) <- getLicense pkg version - addHeader "Content-Length" (show len) - respondSource typePlain $ src .| awaitForever sendChunkBS - -getInstructionsR :: PkgId -> Handler TypedContent -getInstructionsR pkg = do - spec <- getVersionSpecFromQuery - preferMin <- versionPriorityFromQueryIsMin - version <- getBestVersion pkg spec preferMin - `orThrow` sendResponseStatus status400 (NotFoundE [i|Instructions for #{pkg} satisfying #{spec}|]) - (len, src) <- getInstructions pkg version - addHeader "Content-Length" (show len) - respondSource typePlain $ src .| awaitForever sendChunkBS diff --git a/src/Handler/Marketplace.hs b/src/Handler/Marketplace.hs index 776ac5e..d91b52a 100644 --- a/src/Handler/Marketplace.hs +++ b/src/Handler/Marketplace.hs @@ -6,255 +6,265 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + {-# HLINT ignore "Redundant <$>" #-} module Handler.Marketplace where -import Startlude ( ($) - , (&&&) - , (.) - , (<$>) - , (<&>) - , Applicative((*>), pure) - , Bool(True) - , ByteString - , Down(Down) - , Either(Left, Right) - , FilePath - , Foldable(foldMap) - , Functor(fmap) - , Int - , Maybe(..) - , Monad((>>=)) - , MonadIO - , MonadReader - , Monoid(mappend) - , Num((*), (-)) - , Ord((<)) - , ReaderT(runReaderT) - , Text - , Traversable(traverse) - , catMaybes - , const - , decodeUtf8 - , encodeUtf8 - , filter - , flip - , for_ - , fromMaybe - , fst - , head - , headMay - , id - , maybe - , partitionEithers - , readMaybe - , show - , snd - , void - ) +import Startlude ( + Applicative (pure, (*>)), + Bool (True), + ByteString, + Down (Down), + Either (Left, Right), + FilePath, + Foldable (foldMap), + Functor (fmap), + Int, + Maybe (..), + Monad ((>>=)), + MonadIO, + MonadReader, + Monoid (mappend), + Num ((*), (-)), + Ord ((<)), + ReaderT (runReaderT), + Text, + Traversable (traverse), + catMaybes, + const, + decodeUtf8, + encodeUtf8, + filter, + flip, + for_, + fromMaybe, + fst, + head, + headMay, + id, + maybe, + partitionEithers, + readMaybe, + show, + snd, + void, + ($), + (&&&), + (.), + (<$>), + (<&>), + ) -import Conduit ( (.|) - , dropC - , runConduit - , sinkList - , takeC - ) -import Control.Monad.Logger ( MonadLogger - , logWarn - ) -import Control.Monad.Reader.Has ( Has - , ask - ) -import Crypto.Hash ( SHA256 ) -import Crypto.Hash.Conduit ( hashFile ) -import Data.Aeson ( decode - , eitherDecode - , eitherDecodeStrict - ) -import qualified Data.Attoparsec.Text as Atto +import Conduit ( + dropC, + runConduit, + sinkList, + takeC, + (.|), + ) +import Control.Monad.Logger ( + MonadLogger, + logWarn, + ) +import Control.Monad.Reader.Has ( + Has, + ask, + ) +import Crypto.Hash (SHA256) +import Crypto.Hash.Conduit (hashFile) +import Data.Aeson ( + decode, + eitherDecode, + eitherDecodeStrict, + ) +import Data.Attoparsec.Text qualified as Atto + +import Data.Attoparsec.Text ( + Parser, + parseOnly, + ) +import Data.ByteArray.Encoding ( + Base (..), + convertToBase, + ) +import Data.ByteString.Base64 (encodeBase64) +import Data.ByteString.Lazy qualified as LBS +import Data.Conduit.List qualified as CL +import Data.HashMap.Strict qualified as HM +import Data.List ( + lookup, + sortOn, + ) +import Data.String.Interpolate.IsString ( + i, + ) +import Data.Text qualified as T +import Data.Text.Lazy qualified as TL +import Data.Text.Lazy.Builder qualified as TB +import Database.Esqueleto.Experimental ( + Entity (entityKey, entityVal), + SqlBackend, + asc, + desc, + from, + orderBy, + select, + table, + (^.), + ) +import Database.Marketplace ( + collateVersions, + fetchAllAppVersions, + fetchLatestApp, + getPkgData, + getPkgDependencyData, + searchServices, + zipCategories, + zipDependencyVersions, + ) +import Database.Persist ( + PersistUniqueRead (getBy), + insertUnique, + ) +import Foundation ( + Handler, + RegistryCtx (appConnPool, appSettings), + Route (InstructionsR, LicenseR), + ) +import Handler.Util (getVersionSpecFromQuery) +import Lib.Error (S9Error (..)) +import Lib.PkgRepository ( + PkgRepo, + getIcon, + getManifest, + ) +import Lib.Types.AppIndex (PkgId) +import Lib.Types.Emver ( + Version, + VersionRange, + parseRange, + parseVersion, + satisfies, + ) +import Model ( + Category (..), + EntityField (..), + EosHash (EosHash, eosHashHash), + Key (PkgRecordKey, unPkgRecordKey), + OsVersion (..), + PkgRecord (..), + Unique (UniqueVersion), + VersionRecord (..), + ) +import Network.HTTP.Types ( + status400, + status404, + ) +import Protolude.Unsafe (unsafeFromJust) +import Settings (AppSettings (marketplaceName, resourcesDir)) +import System.FilePath (()) +import UnliftIO.Async (mapConcurrently) +import UnliftIO.Directory (listDirectory) +import Util.Shared ( + filterDependencyBestVersion, + filterDependencyOsCompatible, + filterLatestVersionFromSpec, + filterPkgOsCompatible, + ) +import Yesod.Core ( + Content (ContentFile), + MonadHandler, + MonadResource, + RenderRoute (renderRoute), + TypedContent, + YesodRequest (..), + addHeader, + getRequest, + getYesod, + getsYesod, + lookupGetParam, + respond, + sendResponseStatus, + typeOctet, + ) +import Yesod.Core.Types (JSONResponse (..)) +import Yesod.Persist (YesodDB) +import Yesod.Persist.Core (YesodPersist (runDB)) -import Data.Attoparsec.Text ( Parser - , parseOnly - ) -import Data.ByteArray.Encoding ( Base(..) - , convertToBase - ) -import Data.ByteString.Base64 ( encodeBase64 ) -import qualified Data.ByteString.Lazy as LBS -import qualified Data.Conduit.List as CL -import qualified Data.HashMap.Strict as HM -import Data.List ( lookup - , sortOn - ) -import Data.String.Interpolate.IsString - ( i ) -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Builder as TB -import Database.Esqueleto.Experimental - ( Entity(entityKey, entityVal) - , SqlBackend - , (^.) - , asc - , desc - , from - , orderBy - , select - , table - ) -import Database.Marketplace ( collateVersions - , fetchAllAppVersions - , fetchLatestApp - , getPkgData - , getPkgDependencyData - , searchServices - , zipCategories - , zipDependencyVersions - ) -import Database.Persist ( PersistUniqueRead(getBy) - , insertUnique - ) -import Foundation ( Handler - , RegistryCtx(appConnPool, appSettings) - , Route(InstructionsR, LicenseR) - ) -import Handler.Types.Marketplace ( CategoryTitle - , DependencyRes(..) - , EosRes(..) - , InfoRes(InfoRes) - , OrderArrangement(DESC) - , PackageListDefaults - ( PackageListDefaults - , packageListCategory - , packageListOrder - , packageListPageLimit - , packageListPageNumber - , packageListQuery - ) - , PackageListRes(..) - , PackageMetadata(..) - , PackageReq(packageReqId, packageReqVersion) - , PackageRes(..) - , ReleaseNotes(ReleaseNotes) - , VersionLatestRes(..) - ) -import Lib.Error ( S9Error(..) ) -import Lib.PkgRepository ( PkgRepo - , getIcon - , getManifest - ) -import Lib.Types.AppIndex ( PkgId ) -import Lib.Types.Emver ( Version - , VersionRange - , parseRange - , parseVersion - , satisfies - ) -import Model ( Category(..) - , EntityField(..) - , EosHash(EosHash, eosHashHash) - , Key(PkgRecordKey, unPkgRecordKey) - , OsVersion(..) - , PkgRecord(..) - , Unique(UniqueVersion) - , VersionRecord(..) - ) -import Network.HTTP.Types ( status400 - , status404 - ) -import Protolude.Unsafe ( unsafeFromJust ) -import Settings ( AppSettings(marketplaceName, resourcesDir) ) -import System.FilePath ( () ) -import UnliftIO.Async ( mapConcurrently ) -import UnliftIO.Directory ( listDirectory ) -import Util.Shared ( filterDependencyBestVersion - , filterDependencyOsCompatible - , filterLatestVersionFromSpec - , filterPkgOsCompatible - , getVersionSpecFromQuery - ) -import Yesod.Core ( Content(ContentFile) - , MonadHandler - , MonadResource - , RenderRoute(renderRoute) - , TypedContent - , YesodRequest(..) - , addHeader - , getRequest - , getYesod - , getsYesod - , lookupGetParam - , respond - , sendResponseStatus - , typeOctet - ) -import Yesod.Core.Types ( JSONResponse(..) ) -import Yesod.Persist ( YesodDB ) -import Yesod.Persist.Core ( YesodPersist(runDB) ) queryParamAs :: MonadHandler m => Text -> Parser a -> m (Maybe a) -queryParamAs k p = lookupGetParam k >>= \case - Nothing -> pure Nothing - Just x -> case parseOnly p x of - Left e -> - sendResponseStatus @_ @Text status400 [i|Invalid Request! The query parameter '#{k}' failed to parse: #{e}|] - Right a -> pure (Just a) +queryParamAs k p = + lookupGetParam k >>= \case + Nothing -> pure Nothing + Just x -> case parseOnly p x of + Left e -> + sendResponseStatus @_ @Text status400 [i|Invalid Request! The query parameter '#{k}' failed to parse: #{e}|] + Right a -> pure (Just a) + getInfoR :: Handler (JSONResponse InfoRes) getInfoR = do - name <- getsYesod $ marketplaceName . appSettings - allCategories <- runDB $ select $ do - cats <- from $ table @Category - orderBy [asc (cats ^. CategoryPriority)] - pure cats + name <- getsYesod $ marketplaceName . appSettings + allCategories <- runDB $ + select $ do + cats <- from $ table @Category + orderBy [asc (cats ^. CategoryPriority)] + pure cats pure $ JSONResponse $ InfoRes name $ categoryName . entityVal <$> allCategories + getEosVersionR :: Handler (JSONResponse (Maybe EosRes)) getEosVersionR = do - eosVersion <- queryParamAs "eos-version" parseVersion - allEosVersions <- runDB $ select $ do - vers <- from $ table @OsVersion - orderBy [desc (vers ^. OsVersionCreatedAt)] - pure vers - let osV = entityVal <$> allEosVersions + eosVersion <- queryParamAs "eos-version" parseVersion + allEosVersions <- runDB $ + select $ do + vers <- from $ table @OsVersion + orderBy [desc (vers ^. OsVersionCreatedAt)] + pure vers + let osV = entityVal <$> allEosVersions let mLatest = head osV let mappedVersions = - ReleaseNotes - $ HM.fromList - $ sortOn (Down . fst) - $ filter (maybe (const True) (<) eosVersion . fst) - $ (\v -> (osVersionNumber v, osVersionReleaseNotes v)) - <$> osV - pure . JSONResponse $ mLatest <&> \latest -> EosRes { eosResVersion = osVersionNumber latest - , eosResHeadline = osVersionHeadline latest - , eosResReleaseNotes = mappedVersions - } + ReleaseNotes $ + HM.fromList $ + sortOn (Down . fst) $ + filter (maybe (const True) (<) eosVersion . fst) $ + (\v -> (osVersionNumber v, osVersionReleaseNotes v)) + <$> osV + pure . JSONResponse $ + mLatest <&> \latest -> + EosRes + { eosResVersion = osVersionNumber latest + , eosResHeadline = osVersionHeadline latest + , eosResReleaseNotes = mappedVersions + } + getReleaseNotesR :: PkgId -> Handler ReleaseNotes getReleaseNotesR pkg = do - appConnPool <- appConnPool <$> getYesod + appConnPool <- appConnPool <$> getYesod versionRecords <- runDB $ fetchAllAppVersions appConnPool pkg pure $ constructReleaseNotesApiRes versionRecords where constructReleaseNotesApiRes :: [VersionRecord] -> ReleaseNotes constructReleaseNotesApiRes vers = do - ReleaseNotes - $ HM.fromList - $ sortOn (Down . fst) - $ (versionRecordNumber &&& versionRecordReleaseNotes) - <$> vers + ReleaseNotes $ + HM.fromList $ + sortOn (Down . fst) $ + (versionRecordNumber &&& versionRecordReleaseNotes) + <$> vers + getEosR :: Handler TypedContent getEosR = do - spec <- getVersionSpecFromQuery - root <- getsYesod $ ( "eos") . resourcesDir . appSettings + spec <- getVersionSpecFromQuery + root <- getsYesod $ ( "eos") . resourcesDir . appSettings subdirs <- listDirectory root let (failures, successes) = partitionEithers $ Atto.parseOnly parseVersion . T.pack <$> subdirs for_ failures $ \f -> $logWarn [i|Emver Parse Failure for EOS: #{f}|] let mVersion = headMay . sortOn Down . filter (`satisfies` spec) $ successes case mVersion of - Nothing -> sendResponseStatus status404 (NotFoundE [i|EOS version satisfying #{spec}|]) + Nothing -> sendResponseStatus status404 (NotFoundE [i|EOS version satisfying #{spec}|]) Just version -> do let imgPath = root show version "eos.img" h <- runDB $ retrieveHash version imgPath @@ -265,187 +275,32 @@ getEosR = do retrieveHash v fp = do mHash <- getBy (UniqueVersion v) case mHash of - Just h -> pure . eosHashHash . entityVal $ h + Just h -> pure . eosHashHash . entityVal $ h Nothing -> do h <- hashFile @_ @SHA256 fp let t = decodeUtf8 $ convertToBase Base16 h void $ insertUnique (EosHash v t) -- lazily populate pure t + -- TODO refactor with conduit getVersionLatestR :: Handler VersionLatestRes getVersionLatestR = do getParameters <- reqGetParams <$> getRequest case lookup "ids" getParameters of - Nothing -> sendResponseStatus status400 (InvalidParamsE "get:ids" "") + Nothing -> sendResponseStatus status400 (InvalidParamsE "get:ids" "") Just packages -> case eitherDecode $ LBS.fromStrict $ encodeUtf8 packages of - Left _ -> sendResponseStatus status400 (InvalidParamsE "get:ids" packages) + Left _ -> sendResponseStatus status400 (InvalidParamsE "get:ids" packages) Right p -> do - let packageList = (, Nothing) <$> p + let packageList = (,Nothing) <$> p found <- runDB $ traverse fetchLatestApp $ fst <$> packageList - pure - $ VersionLatestRes - $ HM.union - ( HM.fromList - $ (\v -> - (unPkgRecordKey . entityKey $ fst v, Just $ versionRecordNumber $ entityVal $ snd v) - ) - <$> catMaybes found - ) - $ HM.fromList packageList - -getPackageListR :: Handler PackageListRes -getPackageListR = do - osPredicate <- getOsVersionQuery <&> \case - Nothing -> const True - Just v -> flip satisfies v - pkgIds <- getPkgIdsQuery - filteredPackages <- case pkgIds of - Nothing -> do - -- query for all - category <- getCategoryQuery - page <- getPageQuery - limit' <- getLimitQuery - query <- T.strip . fromMaybe (packageListQuery defaults) <$> lookupGetParam "query" - runDB - $ runConduit - $ searchServices category query - .| collateVersions - .| zipCategories - -- empty list since there are no requested packages in this case - .| filterLatestVersionFromSpec [] - .| filterPkgOsCompatible osPredicate - -- pages start at 1 for some reason. TODO: make pages start at 0 - .| (dropC (limit' * (page - 1)) *> takeC limit') - .| sinkList - Just packages' -> do - -- for each item in list get best available from version range - let vMap = (packageReqId &&& packageReqVersion) <$> packages' - runDB - -- TODO could probably be better with sequenceConduits - . runConduit - $ getPkgData (packageReqId <$> packages') - .| collateVersions - .| zipCategories - .| filterLatestVersionFromSpec vMap - .| filterPkgOsCompatible osPredicate - .| sinkList - -- NOTE: if a package's dependencies do not meet the system requirements, it is currently omitted from the list - pkgsWithDependencies <- runDB $ mapConcurrently (getPackageDependencies osPredicate) filteredPackages - PackageListRes <$> mapConcurrently constructPackageListApiRes pkgsWithDependencies - where - defaults = PackageListDefaults { packageListOrder = DESC - , packageListPageLimit = 20 - , packageListPageNumber = 1 - , packageListCategory = Nothing - , packageListQuery = "" - } - getPkgIdsQuery :: Handler (Maybe [PackageReq]) - getPkgIdsQuery = lookupGetParam "ids" >>= \case - Nothing -> pure Nothing - Just ids -> case eitherDecodeStrict (encodeUtf8 ids) of - Left _ -> do - let e = InvalidParamsE "get:ids" ids - $logWarn (show e) - sendResponseStatus status400 e - Right a -> pure a - getCategoryQuery :: Handler (Maybe CategoryTitle) - getCategoryQuery = lookupGetParam "category" >>= \case - Nothing -> pure Nothing - Just c -> case readMaybe . T.toUpper $ c of - Nothing -> do - let e = InvalidParamsE "get:category" c - $logWarn (show e) - sendResponseStatus status400 e - Just t -> pure $ Just t - getPageQuery :: Handler Int - getPageQuery = lookupGetParam "page" >>= \case - Nothing -> pure $ packageListPageNumber defaults - Just p -> case readMaybe p of - Nothing -> do - let e = InvalidParamsE "get:page" p - $logWarn (show e) - sendResponseStatus status400 e - Just t -> pure $ case t of - 0 -> 1 -- disallow page 0 so offset is not negative - _ -> t - getLimitQuery :: Handler Int - getLimitQuery = lookupGetParam "per-page" >>= \case - Nothing -> pure $ packageListPageLimit defaults - Just pp -> case readMaybe pp of - Nothing -> do - let e = InvalidParamsE "get:per-page" pp - $logWarn (show e) - sendResponseStatus status400 e - Just l -> pure l - getOsVersionQuery :: Handler (Maybe VersionRange) - getOsVersionQuery = lookupGetParam "eos-version-compat" >>= \case - Nothing -> pure Nothing - Just osv -> case Atto.parseOnly parseRange osv of - Left _ -> do - let e = InvalidParamsE "get:eos-version-compat" osv - $logWarn (show e) - sendResponseStatus status400 e - Right v -> pure $ Just v - getPackageDependencies :: (MonadIO m, MonadLogger m) - => (Version -> Bool) - -> PackageMetadata - -> ReaderT - SqlBackend - m - ( Key PkgRecord - , [Category] - , [Version] - , Version - , [(Key PkgRecord, Text, Version)] - ) - getPackageDependencies osPredicate PackageMetadata { packageMetadataPkgId = pkg, packageMetadataPkgVersionRecords = pkgVersions, packageMetadataPkgCategories = pkgCategories, packageMetadataPkgVersion = pkgVersion } - = do - let pkgId = PkgRecordKey pkg - let pkgVersions' = versionRecordNumber . entityVal <$> pkgVersions - let pkgCategories' = entityVal <$> pkgCategories - pkgDepInfo <- getPkgDependencyData pkgId pkgVersion - pkgDepInfoWithVersions <- traverse zipDependencyVersions pkgDepInfo - let compatiblePkgDepInfo = fmap (filterDependencyOsCompatible osPredicate) pkgDepInfoWithVersions - res <- catMaybes <$> traverse filterDependencyBestVersion compatiblePkgDepInfo - pure (pkgId, pkgCategories', pkgVersions', pkgVersion, res) - constructPackageListApiRes :: (MonadResource m, MonadReader r m, Has AppSettings r, Has PkgRepo r) - => ( Key PkgRecord - , [Category] - , [Version] - , Version - , [(Key PkgRecord, Text, Version)] - ) - -> m PackageRes - constructPackageListApiRes (pkgKey, pkgCategories, pkgVersions, pkgVersion, dependencies) = do - settings <- ask @_ @_ @AppSettings - let pkgId = unPkgRecordKey pkgKey - manifest <- flip runReaderT settings $ (snd <$> getManifest pkgId pkgVersion) >>= \bs -> - runConduit $ bs .| CL.foldMap LBS.fromStrict - icon <- loadIcon pkgId pkgVersion - deps <- constructDependenciesApiRes dependencies - pure $ PackageRes { packageResIcon = encodeBase64 icon -- pass through raw JSON Value, we have checked its correct parsing above - , packageResManifest = unsafeFromJust . decode $ manifest - , packageResCategories = categoryName <$> pkgCategories - , packageResInstructions = basicRender $ InstructionsR pkgId - , packageResLicense = basicRender $ LicenseR pkgId - , packageResVersions = pkgVersions - , packageResDependencies = HM.fromList deps - } - constructDependenciesApiRes :: (MonadResource m, MonadReader r m, Has PkgRepo r) - => [(Key PkgRecord, Text, Version)] - -> m [(PkgId, DependencyRes)] - constructDependenciesApiRes deps = traverse - (\(depKey, depTitle, depVersion) -> do - let depId = unPkgRecordKey depKey - icon <- loadIcon depId depVersion - pure (depId, DependencyRes { dependencyResTitle = depTitle, dependencyResIcon = encodeBase64 icon }) - ) - deps - loadIcon :: (MonadResource m, MonadReader r m, Has PkgRepo r) => PkgId -> Version -> m ByteString - loadIcon pkg version = do - (_, _, src) <- getIcon pkg version - runConduit $ src .| CL.foldMap id - -basicRender :: RenderRoute a => Route a -> Text -basicRender = TL.toStrict . TB.toLazyText . foldMap (mappend (TB.singleton '/') . TB.fromText) . fst . renderRoute + pure $ + VersionLatestRes $ + HM.union + ( HM.fromList $ + ( \v -> + (unPkgRecordKey . entityKey $ fst v, Just $ versionRecordNumber $ entityVal $ snd v) + ) + <$> catMaybes found + ) + $ HM.fromList packageList diff --git a/src/Handler/Package.hs b/src/Handler/Package.hs new file mode 100644 index 0000000..7790a8e --- /dev/null +++ b/src/Handler/Package.hs @@ -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 = _ diff --git a/src/Handler/Package/V0/Icon.hs b/src/Handler/Package/V0/Icon.hs new file mode 100644 index 0000000..f3ee362 --- /dev/null +++ b/src/Handler/Package/V0/Icon.hs @@ -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 diff --git a/src/Handler/Package/V0/Index.hs b/src/Handler/Package/V0/Index.hs new file mode 100644 index 0000000..8e7fc34 --- /dev/null +++ b/src/Handler/Package/V0/Index.hs @@ -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 diff --git a/src/Handler/Package/V0/Info.hs b/src/Handler/Package/V0/Info.hs new file mode 100644 index 0000000..672f09d --- /dev/null +++ b/src/Handler/Package/V0/Info.hs @@ -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 diff --git a/src/Handler/Package/V0/Instructions.hs b/src/Handler/Package/V0/Instructions.hs new file mode 100644 index 0000000..d7914e0 --- /dev/null +++ b/src/Handler/Package/V0/Instructions.hs @@ -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 diff --git a/src/Handler/Package/V0/Latest.hs b/src/Handler/Package/V0/Latest.hs new file mode 100644 index 0000000..83dca3a --- /dev/null +++ b/src/Handler/Package/V0/Latest.hs @@ -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 diff --git a/src/Handler/Package/V0/License.hs b/src/Handler/Package/V0/License.hs new file mode 100644 index 0000000..12fae57 --- /dev/null +++ b/src/Handler/Package/V0/License.hs @@ -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 diff --git a/src/Handler/Package/V0/Manifest.hs b/src/Handler/Package/V0/Manifest.hs new file mode 100644 index 0000000..d578952 --- /dev/null +++ b/src/Handler/Package/V0/Manifest.hs @@ -0,0 +1 @@ +module Handler.Package.V0.Manifest where diff --git a/src/Handler/Package/V0/ReleaseNotes.hs b/src/Handler/Package/V0/ReleaseNotes.hs new file mode 100644 index 0000000..60f94e0 --- /dev/null +++ b/src/Handler/Package/V0/ReleaseNotes.hs @@ -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 diff --git a/src/Handler/Package/V0/S9PK.hs b/src/Handler/Package/V0/S9PK.hs new file mode 100644 index 0000000..b240255 --- /dev/null +++ b/src/Handler/Package/V0/S9PK.hs @@ -0,0 +1 @@ +module Handler.Package.V0.S9PK where diff --git a/src/Handler/Package/V0/Version.hs b/src/Handler/Package/V0/Version.hs new file mode 100644 index 0000000..79a5f4b --- /dev/null +++ b/src/Handler/Package/V0/Version.hs @@ -0,0 +1 @@ +module Handler.Package.V0.Version where diff --git a/src/Handler/Types/Api.hs b/src/Handler/Types/Api.hs new file mode 100644 index 0000000..f540b68 --- /dev/null +++ b/src/Handler/Types/Api.hs @@ -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 diff --git a/src/Handler/Types/Marketplace.hs b/src/Handler/Types/Marketplace.hs deleted file mode 100644 index 729be94..0000000 --- a/src/Handler/Types/Marketplace.hs +++ /dev/null @@ -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) diff --git a/src/Handler/Util.hs b/src/Handler/Util.hs new file mode 100644 index 0000000..8a5efbf --- /dev/null +++ b/src/Handler/Util.hs @@ -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 \ No newline at end of file diff --git a/src/Handler/Version.hs b/src/Handler/Version.hs index 925c098..173a8e3 100644 --- a/src/Handler/Version.hs +++ b/src/Handler/Version.hs @@ -14,12 +14,12 @@ import Data.String.Interpolate.IsString ( i ) import Foundation ( Handler ) import Handler.Types.Status ( AppVersionRes(AppVersionRes) ) +import Handler.Util ( orThrow ) import Lib.Error ( S9Error(NotFoundE) ) import Lib.PkgRepository ( getBestVersion ) import Lib.Types.AppIndex ( PkgId ) import Network.HTTP.Types.Status ( status404 ) import Util.Shared ( getVersionSpecFromQuery - , orThrow , versionPriorityFromQueryIsMin ) diff --git a/src/Lib/Conduit.hs b/src/Lib/Conduit.hs new file mode 100644 index 0000000..ab4cbf6 --- /dev/null +++ b/src/Lib/Conduit.hs @@ -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 diff --git a/src/Lib/Ord.hs b/src/Lib/Ord.hs new file mode 100644 index 0000000..1bcef45 --- /dev/null +++ b/src/Lib/Ord.hs @@ -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 \ No newline at end of file diff --git a/src/Startlude.hs b/src/Startlude.hs index ec17f9d..5c487a8 100644 --- a/src/Startlude.hs +++ b/src/Startlude.hs @@ -1,33 +1,37 @@ -module Startlude - ( module X - , module Startlude - ) where +module Startlude ( + module X, + module Startlude, +) where + +import Control.Arrow as X ( + (&&&), + ) +import Control.Error.Util as X +import Data.Coerce as X +import Data.String as X ( + String, + fromString, + ) +import Data.Time.Clock as X +import Protolude as X hiding ( + bool, + hush, + isLeft, + isRight, + note, + readMaybe, + tryIO, + (<.>), + ) +import Protolude qualified as P ( + readMaybe, + ) -import Control.Arrow as X - ( (&&&) ) -import Control.Error.Util as X -import Data.Coerce as X -import Data.String as X - ( String - , fromString - ) -import Data.Time.Clock as X -import Protolude as X - hiding ( (<.>) - , bool - , hush - , isLeft - , isRight - , note - , readMaybe - , tryIO - ) -import qualified Protolude as P - ( readMaybe ) id :: a -> a id = identity -readMaybe :: Read a => Text -> Maybe a -readMaybe = P.readMaybe . toS + +readMaybe :: (Read a) => Text -> Maybe a +readMaybe = P.readMaybe {-# INLINE readMaybe #-} diff --git a/src/Util/Shared.hs b/src/Util/Shared.hs deleted file mode 100644 index 5901e2f..0000000 --- a/src/Util/Shared.hs +++ /dev/null @@ -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 diff --git a/stack.yaml b/stack.yaml index 683ab98..d614ead 100644 --- a/stack.yaml +++ b/stack.yaml @@ -17,7 +17,7 @@ # # resolver: ./custom-snapshot.yaml # resolver: https://example.com/snapshots/2018-01-01.yaml -resolver: lts-18.11 +resolver: nightly-2022-06-06 # User packages to be built. # Various formats can be used as shown in the example below. @@ -40,15 +40,14 @@ packages: # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a # extra-deps: - - protolude-0.3.0 - - esqueleto-3.5.1.0 + - protolude-0.3.1 - monad-logger-extras-0.1.1.1 - persistent-migration-0.3.0 - - rainbow-0.34.2.2 - - terminal-progress-bar-0.4.1 - - wai-request-spec-0.10.2.4 - - warp-3.3.19 - - yesod-auth-basic-0.1.0.3 + # - rainbow-0.34.2.2 + # - terminal-progress-bar-0.4.1 + # - wai-request-spec-0.10.2.4 + # - warp-3.3.19 + # - yesod-auth-basic-0.1.0.3 # Override default flag values for local packages and extra-deps # flags: {}