diff --git a/config/routes b/config/routes index b0580af..e114134 100644 --- a/config/routes +++ b/config/routes @@ -14,9 +14,6 @@ /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 - -- ADMIN API V0 /admin/v0/upload PkgUploadR POST !admin /admin/v0/index PkgIndexR POST !admin diff --git a/src/Application.hs b/src/Application.hs index 3787dd1..bd31bdc 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -1,204 +1,227 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -module Application - ( appMain - , develMain - , makeFoundation - , makeLogWare - , shutdownApp - , shutdownAll - , shutdownWeb - , startApp - , startWeb + +module Application ( + appMain, + develMain, + makeFoundation, + makeLogWare, + shutdownApp, + shutdownAll, + shutdownWeb, + startApp, + startWeb, + -- * for DevelMain - , getApplicationRepl - , getAppSettings + getApplicationRepl, + getAppSettings, + -- * for GHCI - , handler - , db - ) where + handler, + db, +) where -import Startlude ( ($) - , (++) - , (.) - , (<$>) - , (<||>) - , Applicative(pure) - , Async(asyncThreadId) - , Bool(False, True) - , Either(Left, Right) - , Eq((==)) - , ExitCode(ExitSuccess) - , IO - , Int - , Maybe(Just) - , Monad((>>=), return) - , MonadIO(..) - , Print(putStr, putStrLn) - , ReaderT(runReaderT) - , Text - , ThreadId - , async - , flip - , for_ - , forever - , forkIO - , fromIntegral - , killThread - , newEmptyMVar - , newMVar - , onException - , panic - , print - , putMVar - , show - , stdout - , swapMVar - , takeMVar - , void - , waitEitherCatchCancel - , when - ) +import Startlude ( + Applicative (pure), + Async (asyncThreadId), + Bool (False, True), + Either (Left, Right), + Eq ((==)), + ExitCode (ExitSuccess), + IO, + Int, + Maybe (Just), + Monad (return, (>>=)), + MonadIO (..), + Print (putStr, putStrLn), + ReaderT (runReaderT), + Text, + ThreadId, + async, + flip, + for_, + forever, + forkIO, + fromIntegral, + killThread, + newEmptyMVar, + newMVar, + onException, + panic, + print, + putMVar, + show, + stdout, + swapMVar, + takeMVar, + void, + waitEitherCatchCancel, + when, + ($), + (++), + (.), + (<$>), + (<||>), + ) -import Control.Monad.Logger ( LoggingT - , liftLoc - , runLoggingT - ) -import Data.Default ( Default(def) ) -import Database.Persist.Postgresql ( createPostgresqlPool - , pgConnStr - , pgPoolSize - , runMigration - , runSqlPool - ) -import Language.Haskell.TH.Syntax ( qLocation ) -import Network.Wai ( Application - , Middleware - , Request(requestHeaders) - , ResponseReceived - ) -import Network.Wai.Handler.Warp ( Settings - , defaultSettings - , defaultShouldDisplayException - , getPort - , runSettings - , setHTTP2Disabled - , setHost - , setOnException - , setPort - , setTimeout - ) -import Network.Wai.Handler.WarpTLS ( runTLS - , tlsSettings - ) -import Network.Wai.Middleware.AcceptOverride - ( acceptOverride ) -import Network.Wai.Middleware.Autohead - ( autohead ) -import Network.Wai.Middleware.Cors ( CorsResourcePolicy(..) - , cors - , simpleCorsResourcePolicy - ) -import Network.Wai.Middleware.MethodOverride - ( methodOverride ) -import Network.Wai.Middleware.RequestLogger - ( Destination(Logger) - , OutputFormat(..) - , destination - , mkRequestLogger - , outputFormat - ) -import System.IO ( BufferMode(..) - , hSetBuffering - ) -import System.Log.FastLogger ( defaultBufSize - , newStdoutLoggerSet - , toLogStr - ) -import Yesod.Core ( HandlerFor - , LogLevel(LevelError) - , Yesod(messageLoggerSource) - , logInfo - , mkYesodDispatch - , toWaiAppPlain - , typeOctet - ) -import Yesod.Core.Types ( Logger(loggerSet) ) -import Yesod.Default.Config2 ( configSettingsYml - , develMainHelper - , getDevSettings - , loadYamlSettings - , loadYamlSettingsArgs - , makeYesodLogger - , useEnv - ) +import Control.Monad.Logger ( + LoggingT, + liftLoc, + runLoggingT, + ) +import Data.Default (Default (def)) +import Database.Persist.Postgresql ( + createPostgresqlPool, + pgConnStr, + pgPoolSize, + runMigration, + runSqlPool, + ) +import Language.Haskell.TH.Syntax (qLocation) +import Network.Wai ( + Application, + Middleware, + Request (requestHeaders), + ResponseReceived, + ) +import Network.Wai.Handler.Warp ( + Settings, + defaultSettings, + defaultShouldDisplayException, + getPort, + runSettings, + setHTTP2Disabled, + setHost, + setOnException, + setPort, + setTimeout, + ) +import Network.Wai.Handler.WarpTLS ( + runTLS, + tlsSettings, + ) +import Network.Wai.Middleware.AcceptOverride ( + acceptOverride, + ) +import Network.Wai.Middleware.Autohead ( + autohead, + ) +import Network.Wai.Middleware.Cors ( + CorsResourcePolicy (..), + cors, + simpleCorsResourcePolicy, + ) +import Network.Wai.Middleware.MethodOverride ( + methodOverride, + ) +import Network.Wai.Middleware.RequestLogger ( + Destination (Logger), + OutputFormat (..), + destination, + mkRequestLogger, + outputFormat, + ) +import System.IO ( + BufferMode (..), + hSetBuffering, + ) +import System.Log.FastLogger ( + defaultBufSize, + newStdoutLoggerSet, + toLogStr, + ) +import Yesod.Core ( + HandlerFor, + LogLevel (LevelError), + Yesod (messageLoggerSource), + logInfo, + mkYesodDispatch, + toWaiAppPlain, + typeOctet, + ) +import Yesod.Core.Types (Logger (loggerSet)) +import Yesod.Default.Config2 ( + configSettingsYml, + develMainHelper, + getDevSettings, + loadYamlSettings, + loadYamlSettingsArgs, + makeYesodLogger, + useEnv, + ) + +import Control.Lens (both) +import Data.List (lookup) +import Data.String.Interpolate.IsString ( + i, + ) +import Database.Persist.Migration qualified +import Database.Persist.Migration.Postgres qualified +import Database.Persist.Sql (SqlBackend) +import Foundation ( + Handler, + RegistryCtx (..), + Route (..), + resourcesRegistryCtx, + setWebProcessThreadId, + unsafeHandler, + ) +import Handler.Admin ( + deleteCategoryR, + deletePkgCategorizeR, + getPkgDeindexR, + postCategoryR, + postPkgCategorizeR, + postPkgDeindexR, + postPkgIndexR, + postPkgUploadR, + ) +import Handler.Eos (getEosR, getEosVersionR) +import Handler.Package +import Lib.PkgRepository (watchEosRepoRoot) +import Lib.Ssl ( + doesSslNeedRenew, + renewSslCerts, + setupSsl, + ) +import Migration (manualMigration) +import Model (migrateAll) +import Network.HTTP.Types.Header (hOrigin) +import Network.Wai.Middleware.Gzip ( + GzipFiles (GzipCompress), + GzipSettings (gzipCheckMime, gzipFiles), + defaultCheckMime, + gzip, + ) +import Network.Wai.Middleware.RequestLogger.JSON ( + formatAsJSONWithHeaders, + ) +import Settings ( + AppPort, + AppSettings (..), + configSettingsYmlValue, + ) +import System.Directory (createDirectoryIfMissing) +import System.Posix.Process (exitImmediately) +import System.Time.Extra (sleep) +import Yesod (YesodPersist (runDB)) -import Control.Lens ( both ) -import Data.List ( lookup ) -import Data.String.Interpolate.IsString - ( i ) -import qualified Database.Persist.Migration -import qualified Database.Persist.Migration.Postgres -import Database.Persist.Sql ( SqlBackend ) -import Foundation ( Handler - , RegistryCtx(..) - , Route(..) - , resourcesRegistryCtx - , setWebProcessThreadId - , unsafeHandler - ) -import Handler.Admin ( deleteCategoryR - , deletePkgCategorizeR - , getPkgDeindexR - , postCategoryR - , postPkgCategorizeR - , postPkgDeindexR - , postPkgIndexR - , postPkgUploadR - ) -import Handler.ErrorLogs ( postErrorLogsR ) -import Handler.Marketplace ( getEosR - , getEosVersionR - ) -import Handler.Package -import Lib.PkgRepository ( watchEosRepoRoot ) -import Lib.Ssl ( doesSslNeedRenew - , renewSslCerts - , setupSsl - ) -import Migration ( manualMigration ) -import Model ( migrateAll ) -import Network.HTTP.Types.Header ( hOrigin ) -import Network.Wai.Middleware.Gzip ( GzipFiles(GzipCompress) - , GzipSettings(gzipCheckMime, gzipFiles) - , defaultCheckMime - , gzip - ) -import Network.Wai.Middleware.RequestLogger.JSON - ( formatAsJSONWithHeaders ) -import Settings ( AppPort - , AppSettings(..) - , configSettingsYmlValue - ) -import System.Directory ( createDirectoryIfMissing ) -import System.Posix.Process ( exitImmediately ) -import System.Time.Extra ( sleep ) -import Yesod ( YesodPersist(runDB) ) -- This line actually creates our YesodDispatch instance. It is the second half -- of the call to mkYesodData which occurs in Foundation.hs. Please see the -- comments there for more details. mkYesodDispatch "RegistryCtx" resourcesRegistryCtx + -- | This function allocates resources (such as a database connection pool), -- performs initialization and returns a foundation datatype value. This is also -- the place to put your migrate statements to have automatic database @@ -207,20 +230,20 @@ makeFoundation :: AppSettings -> IO RegistryCtx makeFoundation appSettings = do -- Some basic initializations: HTTP connection manager, logger, and static -- subsite. - appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger + appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger appWebServerThreadId <- newEmptyMVar - appShouldRestartWeb <- newMVar False + appShouldRestartWeb <- newMVar False -- We need a log function to create a connection pool. We need a connection -- pool to create our foundation. And we need our foundation to get a -- logging function. To get out of this loop, we initially create a -- temporary foundation without a real connection pool, get a log function -- from there, and then create the real foundation. - let mkFoundation appConnPool appStopFsNotifyEos = RegistryCtx { .. } --- The RegistryCtx {..} syntax is an example of record wild cards. For more --- information, see: --- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html + let mkFoundation appConnPool appStopFsNotifyEos = RegistryCtx{..} + -- The RegistryCtx {..} syntax is an example of record wild cards. For more + -- information, see: + -- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html tempFoundation = mkFoundation (panic "connPool forced in tempFoundation") (panic "stopFsNotify forced in tempFoundation") logFunc = messageLoggerSource tempFoundation appLogger @@ -228,8 +251,9 @@ makeFoundation appSettings = do createDirectoryIfMissing True (errorLogRoot appSettings) -- Create the database connection pool - pool <- flip runLoggingT logFunc - $ createPostgresqlPool (pgConnStr $ appDatabaseConf appSettings) (pgPoolSize . appDatabaseConf $ appSettings) + pool <- + flip runLoggingT logFunc $ + createPostgresqlPool (pgConnStr $ appDatabaseConf appSettings) (pgPoolSize . appDatabaseConf $ appSettings) stopEosWatch <- runLoggingT (runReaderT (watchEosRepoRoot pool) appSettings) logFunc @@ -242,6 +266,7 @@ makeFoundation appSettings = do -- Return the foundation return $ mkFoundation pool stopEosWatch + -- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and -- applying some additional middlewares. makeApplication :: RegistryCtx -> IO Application @@ -254,7 +279,7 @@ makeApplication foundation = do -- TODO: change this to the cached version when we have better release processes -- since caches aren't invalidated, publishing a new package/eos won't take effect -- because the cached file will be downloaded. - def { gzipFiles = GzipCompress, gzipCheckMime = defaultCheckMime <||> (== typeOctet) } + def{gzipFiles = GzipCompress, gzipCheckMime = defaultCheckMime <||> (== typeOctet)} pure . logWare . cors dynamicCorsResourcePolicy @@ -265,78 +290,86 @@ makeApplication foundation = do . gzip gzipSettings $ appPlain + dynamicCorsResourcePolicy :: Request -> Maybe CorsResourcePolicy dynamicCorsResourcePolicy req = Just . policy . lookup hOrigin $ requestHeaders req where - policy o = simpleCorsResourcePolicy - { corsOrigins = (\o' -> ([o'], True)) <$> o - , corsMethods = ["GET", "POST", "HEAD", "PUT", "DELETE", "TRACE", "CONNECT", "OPTIONS", "PATCH"] - , corsRequestHeaders = [ "app-version" - , "Accept" - , "Accept-Charset" - , "Accept-Encoding" - , "Accept-Language" - , "Accept-Ranges" - , "Age" - , "Allow" - , "Authorization" - , "Cache-Control" - , "Connection" - , "Content-Encoding" - , "Content-Language" - , "Content-Length" - , "Content-Location" - , "Content-MD5" - , "Content-Range" - , "Content-Type" - , "Date" - , "ETag" - , "Expect" - , "Expires" - , "From" - , "Host" - , "If-Match" - , "If-Modified-Since" - , "If-None-Match" - , "If-Range" - , "If-Unmodified-Since" - , "Last-Modified" - , "Location" - , "Max-Forwards" - , "Pragma" - , "Proxy-Authenticate" - , "Proxy-Authorization" - , "Range" - , "Referer" - , "Retry-After" - , "Server" - , "TE" - , "Trailer" - , "Transfer-Encoding" - , "Upgrade" - , "User-Agent" - , "Vary" - , "Via" - , "WWW-Authenticate" - , "Warning" - , "Content-Disposition" - , "MIME-Version" - , "Cookie" - , "Set-Cookie" - , "Origin" - , "Prefer" - , "Preference-Applied" - ] - , corsIgnoreFailures = True - } + policy o = + simpleCorsResourcePolicy + { corsOrigins = (\o' -> ([o'], True)) <$> o + , corsMethods = ["GET", "POST", "HEAD", "PUT", "DELETE", "TRACE", "CONNECT", "OPTIONS", "PATCH"] + , corsRequestHeaders = + [ "app-version" + , "Accept" + , "Accept-Charset" + , "Accept-Encoding" + , "Accept-Language" + , "Accept-Ranges" + , "Age" + , "Allow" + , "Authorization" + , "Cache-Control" + , "Connection" + , "Content-Encoding" + , "Content-Language" + , "Content-Length" + , "Content-Location" + , "Content-MD5" + , "Content-Range" + , "Content-Type" + , "Date" + , "ETag" + , "Expect" + , "Expires" + , "From" + , "Host" + , "If-Match" + , "If-Modified-Since" + , "If-None-Match" + , "If-Range" + , "If-Unmodified-Since" + , "Last-Modified" + , "Location" + , "Max-Forwards" + , "Pragma" + , "Proxy-Authenticate" + , "Proxy-Authorization" + , "Range" + , "Referer" + , "Retry-After" + , "Server" + , "TE" + , "Trailer" + , "Transfer-Encoding" + , "Upgrade" + , "User-Agent" + , "Vary" + , "Via" + , "WWW-Authenticate" + , "Warning" + , "Content-Disposition" + , "MIME-Version" + , "Cookie" + , "Set-Cookie" + , "Origin" + , "Prefer" + , "Preference-Applied" + ] + , corsIgnoreFailures = True + } + makeLogWare :: RegistryCtx -> IO Middleware -makeLogWare foundation = mkRequestLogger def - { outputFormat = if appDetailedRequestLogging $ appSettings foundation - then Detailed True - else CustomOutputFormatWithDetailsAndHeaders formatAsJSONWithHeaders - , destination = Logger $ loggerSet $ appLogger foundation - } +makeLogWare foundation = + mkRequestLogger + def + { outputFormat = + if appDetailedRequestLogging $ appSettings foundation + then Detailed True + else CustomOutputFormatWithDetailsAndHeaders formatAsJSONWithHeaders + , destination = Logger $ loggerSet $ appLogger foundation + } + makeAuthWare :: RegistryCtx -> Middleware makeAuthWare _ app req res = next @@ -344,40 +377,47 @@ makeAuthWare _ app req res = next next :: IO ResponseReceived next = app req res + -- | Warp settings for the given foundation value. warpSettings :: AppPort -> RegistryCtx -> Settings warpSettings port foundation = - setTimeout 60 - $ setPort (fromIntegral port) - $ setHost (appHost $ appSettings foundation) - $ setOnException (\_req e -> - when (defaultShouldDisplayException e) $ messageLoggerSource - foundation - (appLogger foundation) - $(qLocation >>= liftLoc) - "yesod" - LevelError - (toLogStr $ "Exception from Warp: " ++ show e)) - (setHTTP2Disabled defaultSettings) + setTimeout 60 $ + setPort (fromIntegral port) $ + setHost (appHost $ appSettings foundation) $ + setOnException + ( \_req e -> + when (defaultShouldDisplayException e) $ + messageLoggerSource + foundation + (appLogger foundation) + $(qLocation >>= liftLoc) + "yesod" + LevelError + (toLogStr $ "Exception from Warp: " ++ show e) + ) + (setHTTP2Disabled defaultSettings) + getAppSettings :: IO AppSettings getAppSettings = loadYamlSettings [configSettingsYml] [] useEnv + -- | The @main@ function for an executable running this site. appMain :: IO () appMain = do hSetBuffering stdout LineBuffering -- Get the settings from all relevant sources - settings <- loadYamlSettingsArgs - -- fall back to compile-time values, set to [] to require values at runtime - [configSettingsYmlValue] - - -- allow environment variables to override - useEnv + settings <- + loadYamlSettingsArgs + -- fall back to compile-time values, set to [] to require values at runtime + [configSettingsYmlValue] + -- allow environment variables to override + useEnv -- Generate the foundation from the settings makeFoundation settings >>= startApp + startApp :: RegistryCtx -> IO () startApp foundation = do when (sslAuto . appSettings $ foundation) $ do @@ -387,33 +427,38 @@ startApp foundation = do runLog $ $logInfo "SSL Setup Complete" -- certbot renew loop - void . forkIO $ forever $ flip runReaderT foundation $ do - shouldRenew <- doesSslNeedRenew - runLog $ $logInfo [i|Checking if SSL Certs should be renewed: #{shouldRenew}|] - when shouldRenew $ do - runLog $ $logInfo "Renewing SSL Certs." - renewSslCerts - liftIO $ restartWeb foundation - liftIO $ sleep 86_400 + void . forkIO $ + forever $ + flip runReaderT foundation $ do + shouldRenew <- doesSslNeedRenew + runLog $ $logInfo [i|Checking if SSL Certs should be renewed: #{shouldRenew}|] + when shouldRenew $ do + runLog $ $logInfo "Renewing SSL Certs." + renewSslCerts + liftIO $ restartWeb foundation + liftIO $ sleep 86_400 startWeb foundation where runLog :: MonadIO m => LoggingT m a -> m a runLog a = runLoggingT a (messageLoggerSource foundation (appLogger foundation)) + startWeb :: RegistryCtx -> IO () startWeb foundation = do app <- makeApplication foundation startWeb' app where startWeb' app = (`onException` appStopFsNotifyEos foundation) $ do - let AppSettings {..} = appSettings foundation + let AppSettings{..} = appSettings foundation runLog $ $logInfo [i|Launching Tor Web Server on port #{torPort}|] torAction <- async $ runSettings (warpSettings torPort foundation) app runLog $ $logInfo [i|Launching Web Server on port #{appPort}|] - action <- async $ if sslAuto - then runTLS (tlsSettings sslCertLocation sslKeyLocation) (warpSettings appPort foundation) app - else runSettings (warpSettings appPort foundation) app + action <- + async $ + if sslAuto + then runTLS (tlsSettings sslCertLocation sslKeyLocation) (warpSettings appPort foundation) app + else runSettings (warpSettings appPort foundation) app setWebProcessThreadId (asyncThreadId action, asyncThreadId torAction) foundation res <- waitEitherCatchCancel action torAction @@ -439,52 +484,60 @@ startWeb foundation = do startWeb' app runLog a = runLoggingT a (messageLoggerSource foundation (appLogger foundation)) + restartWeb :: RegistryCtx -> IO () restartWeb foundation = do void $ swapMVar (appShouldRestartWeb foundation) True shutdownWeb foundation + shutdownAll :: [ThreadId] -> IO () shutdownAll threadIds = do for_ threadIds killThread exitImmediately ExitSuccess + -- Careful, you should always spawn this within forkIO so as to avoid accidentally killing the running process shutdownWeb :: RegistryCtx -> IO () -shutdownWeb RegistryCtx {..} = do +shutdownWeb RegistryCtx{..} = do threadIds <- takeMVar appWebServerThreadId void $ both killThread threadIds + -------------------------------------------------------------- -- Functions for DevelMain.hs (a way to run the RegistryCtx from GHCi) -------------------------------------------------------------- getApplicationRepl :: IO (Int, RegistryCtx, Application) getApplicationRepl = do - settings <- getAppSettings + settings <- getAppSettings foundation <- getAppSettings >>= makeFoundation - wsettings <- getDevSettings $ warpSettings (appPort settings) foundation - app1 <- makeApplication foundation + wsettings <- getDevSettings $ warpSettings (appPort settings) foundation + app1 <- makeApplication foundation return (getPort wsettings, foundation, app1) + shutdownApp :: RegistryCtx -> IO () shutdownApp _ = return () + -- | For yesod devel, return the Warp settings and WAI Application. getApplicationDev :: AppPort -> IO (Settings, Application) getApplicationDev port = do - settings <- getAppSettings + settings <- getAppSettings foundation <- makeFoundation settings - app <- makeApplication foundation - wsettings <- getDevSettings $ warpSettings port foundation + app <- makeApplication foundation + wsettings <- getDevSettings $ warpSettings port foundation return (wsettings, app) + -- | main function for use by yesod devel develMain :: IO () develMain = do settings <- getAppSettings develMainHelper $ getApplicationDev $ appPort settings + --------------------------------------------- -- Functions for use in development with GHCi --------------------------------------------- @@ -493,6 +546,7 @@ develMain = do handler :: Handler a -> IO a handler h = getAppSettings >>= makeFoundation >>= flip unsafeHandler h + -- | Run DB queries db :: ReaderT SqlBackend (HandlerFor RegistryCtx) a -> IO a db = handler . runDB diff --git a/src/Database/Marketplace.hs b/src/Database/Marketplace.hs index 25d5f2f..2715be6 100644 --- a/src/Database/Marketplace.hs +++ b/src/Database/Marketplace.hs @@ -1,9 +1,10 @@ +{-# LANGUAGE BlockArguments #-} +{-# HLINT ignore "Fuse on/on" #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} -{-# HLINT ignore "Fuse on/on" #-} - module Database.Marketplace where import Conduit ( @@ -82,25 +83,26 @@ import Startlude ( Maybe (..), Monad, MonadIO, + NonEmpty, ReaderT, Show, Text, headMay, - lift, snd, sortOn, ($), ($>), (.), (<$>), + (<<$>>), ) data PackageMetadata = PackageMetadata { packageMetadataPkgId :: !PkgId - , packageMetadataPkgVersionRecords :: ![Entity VersionRecord] - , packageMetadataPkgCategories :: ![Entity Category] + , packageMetadataPkgVersionRecords :: !(NonEmpty VersionRecord) , packageMetadataPkgVersion :: !Version + , packageMetadataPkgCategories :: ![Category] } deriving (Eq, Show) data PackageDependencyMetadata = PackageDependencyMetadata @@ -111,12 +113,12 @@ data PackageDependencyMetadata = PackageDependencyMetadata deriving (Eq, Show) -searchServices :: +serviceQuerySource :: (MonadResource m, MonadIO m) => Maybe Text -> Text -> ConduitT () (Entity VersionRecord) (ReaderT SqlBackend m) () -searchServices Nothing query = selectSource $ do +serviceQuerySource Nothing query = selectSource $ do service <- from $ table @VersionRecord where_ ( (service ^. VersionRecordDescShort `ilike` (%) ++. val query ++. (%)) @@ -130,7 +132,7 @@ searchServices Nothing query = selectSource $ do , desc (service ^. VersionRecordUpdatedAt) ] pure service -searchServices (Just category) query = selectSource $ do +serviceQuerySource (Just category) query = selectSource $ do services <- from ( do @@ -162,8 +164,8 @@ searchServices (Just category) query = selectSource $ do pure services -getPkgData :: (MonadResource m, MonadIO m) => [PkgId] -> ConduitT () (Entity VersionRecord) (ReaderT SqlBackend m) () -getPkgData pkgs = selectSource $ do +getPkgDataSource :: (MonadResource m, MonadIO m) => [PkgId] -> ConduitT () (Entity VersionRecord) (ReaderT SqlBackend m) () +getPkgDataSource pkgs = selectSource $ do pkgData <- from $ table @VersionRecord where_ (pkgData ^. VersionRecordPkgId `in_` valList (PkgRecordKey <$> pkgs)) pure pkgData @@ -188,29 +190,24 @@ getPkgDependencyData pkgId pkgVersion = select $ do ) -zipCategories :: +getCategoriesFor :: 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 - yield (pkg, vers, raw) + PkgId -> + ReaderT SqlBackend m [Category] +getCategoriesFor pkg = + entityVal <<$>> 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 collateVersions :: MonadUnliftIO m => - ConduitT (Entity VersionRecord) (PkgId, [Entity VersionRecord]) (ReaderT SqlBackend m) () + ConduitT (Entity VersionRecord) (PkgId, [VersionRecord]) (ReaderT SqlBackend m) () collateVersions = awaitForever $ \v0 -> do let pkg = unPkgRecordKey . versionRecordPkgId $ entityVal v0 let pull = do @@ -221,7 +218,7 @@ collateVersions = awaitForever $ \v0 -> do let pkg' = unPkgRecordKey . versionRecordPkgId $ entityVal vn if pkg == pkg' then pure (Just vn) else leftover vn $> Nothing ls <- unfoldM pull - yield (pkg, v0 : ls) + yield (pkg, fmap entityVal $ v0 : ls) zipDependencyVersions :: diff --git a/src/Foundation.hs b/src/Foundation.hs index 53b6eac..a995bf0 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -62,7 +62,6 @@ import Database.Persist.Sql ( SqlPersistT, runSqlPool, ) -import Lib.Registry (S9PK) import Yesod.Core ( AuthResult (Authorized, Unauthorized), LogLevel (..), @@ -112,7 +111,7 @@ import Lib.PkgRepository ( EosRepo, PkgRepo, ) -import Lib.Types.AppIndex (PkgId) +import Lib.Types.AppIndex (PkgId, S9PK) import Model ( Admin (..), Key (AdminKey), diff --git a/src/Handler/Apps.hs b/src/Handler/Apps.hs deleted file mode 100644 index c51d72e..0000000 --- a/src/Handler/Apps.hs +++ /dev/null @@ -1,121 +0,0 @@ -{-# 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 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) - - -data FileExtension = FileExtension !FilePath !(Maybe String) -instance Show FileExtension where - 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}|]) - 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}|]) - addPackageHeader pkg version - void $ recordMetrics pkg version - pkgPath <- - getPackage pkg version >>= \case - Nothing -> sendResponseStatus status404 (NotFoundE [i|#{pkg}@#{version}|]) - Just a -> pure a - respond typeOctet $ ContentFile pkgPath Nothing - - -recordMetrics :: PkgId -> Version -> Handler () -recordMetrics pkg appVersion = do - sa <- runDB $ fetchApp pkg - case sa of - Nothing -> do - $logError [i|#{pkg} not found in database|] - notFound - Just _ -> do - existingVersion <- runDB $ fetchAppVersion pkg appVersion - case existingVersion of - Nothing -> do - $logError [i|#{pkg}@#{appVersion} not found in database|] - notFound - Just _ -> runDB $ createMetric pkg appVersion diff --git a/src/Handler/Eos.hs b/src/Handler/Eos.hs new file mode 100644 index 0000000..ee5c7fb --- /dev/null +++ b/src/Handler/Eos.hs @@ -0,0 +1,5 @@ +module Handler.Eos (module X) where + +import Handler.Eos.V0.EosImg as X +import Handler.Eos.V0.Latest as X + diff --git a/src/Handler/Eos/V0/EosImg.hs b/src/Handler/Eos/V0/EosImg.hs index 833244c..dc6fa79 100644 --- a/src/Handler/Eos/V0/EosImg.hs +++ b/src/Handler/Eos/V0/EosImg.hs @@ -1 +1,53 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + module Handler.Eos.V0.EosImg where + +import Crypto.Hash (SHA256) +import Crypto.Hash.Conduit (hashFile) +import Data.Attoparsec.Text qualified as Atto +import Data.ByteArray.Encoding (Base (..), convertToBase) +import Data.String.Interpolate.IsString (i) +import Data.Text qualified as T +import Database.Persist (Entity (..), insertUnique) +import Database.Persist.Class (getBy) +import Foundation (Handler, RegistryCtx (..)) +import Handler.Util (getVersionSpecFromQuery) +import Lib.Error (S9Error (..)) +import Lib.Types.Emver (Version (..), parseVersion, satisfies) +import Model (EosHash (..), Unique (..)) +import Network.HTTP.Types (status404) +import Settings (AppSettings (..)) +import Startlude (Down (..), FilePath, Maybe (..), Text, decodeUtf8, filter, for_, headMay, partitionEithers, pure, show, sortOn, void, ($), (.), (<$>)) +import System.FilePath (()) +import UnliftIO.Directory (listDirectory) +import Yesod (Content (..), TypedContent, YesodDB, YesodPersist (runDB), addHeader, getsYesod, respond, sendResponseStatus, typeOctet) +import Yesod.Core (logWarn) + + +getEosR :: Handler TypedContent +getEosR = do + spec <- getVersionSpecFromQuery + root <- getsYesod $ ( "eos") . resourcesDir . appSettings + subdirs <- listDirectory root + let (failures, successes) = partitionEithers $ Atto.parseOnly parseVersion . T.pack <$> subdirs + for_ failures $ \f -> $logWarn [i|Emver Parse Failure for EOS: #{f}|] + let mVersion = headMay . sortOn Down . filter (`satisfies` spec) $ successes + case mVersion of + Nothing -> sendResponseStatus status404 (NotFoundE [i|EOS version satisfying #{spec}|]) + Just version -> do + let imgPath = root show version "eos.img" + h <- runDB $ retrieveHash version imgPath + addHeader "x-eos-hash" h + respond typeOctet $ ContentFile imgPath Nothing + where + retrieveHash :: Version -> FilePath -> YesodDB RegistryCtx Text + retrieveHash v fp = do + mHash <- getBy (UniqueVersion v) + case mHash of + 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 diff --git a/src/Handler/Eos/V0/Latest.hs b/src/Handler/Eos/V0/Latest.hs index 5612e7a..d0054eb 100644 --- a/src/Handler/Eos/V0/Latest.hs +++ b/src/Handler/Eos/V0/Latest.hs @@ -3,11 +3,25 @@ module Handler.Eos.V0.Latest where import Data.Aeson (ToJSON (toJSON), object, (.=)) -import Handler.Package.V0.ReleaseNotes (ReleaseNotes) -import Lib.Types.Emver (Version) +import Data.HashMap.Strict qualified as HM +import Database.Esqueleto.Experimental ( + Entity (entityVal), + desc, + from, + orderBy, + select, + table, + (^.), + ) +import Foundation (Handler) +import Handler.Package.V0.ReleaseNotes (ReleaseNotes (..)) +import Handler.Util (queryParamAs) +import Lib.Types.Emver (Version, parseVersion) +import Model (EntityField (..), OsVersion (..)) import Orphans.Emver () -import Startlude (Eq, Generic, Show, Text, (.)) -import Yesod (ToContent (toContent), ToTypedContent (..)) +import Startlude (Bool (..), Down (..), Eq, Generic, Maybe, Ord ((<)), Show, Text, const, filter, fst, head, maybe, pure, sortOn, ($), (&&&), (.), (<$>), (<&>)) +import Yesod (ToContent (toContent), ToTypedContent (..), YesodPersist (runDB)) +import Yesod.Core.Types (JSONResponse (..)) data EosRes = EosRes @@ -22,4 +36,30 @@ instance ToJSON EosRes where instance ToContent EosRes where toContent = toContent . toJSON instance ToTypedContent EosRes where - toTypedContent = toTypedContent . toJSON \ No newline at end of file + toTypedContent = toTypedContent . toJSON + + +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 + let mLatest = head osV + let mappedVersions = + ReleaseNotes $ + HM.fromList $ + sortOn (Down . fst) $ + filter (maybe (const True) (<) eosVersion . fst) $ + ((osVersionNumber &&& osVersionReleaseNotes)) + <$> osV + pure . JSONResponse $ + mLatest <&> \latest -> + EosRes + { eosResVersion = osVersionNumber latest + , eosResHeadline = osVersionHeadline latest + , eosResReleaseNotes = mappedVersions + } diff --git a/src/Handler/ErrorLogs.hs b/src/Handler/ErrorLogs.hs deleted file mode 100644 index 6964a9a..0000000 --- a/src/Handler/ErrorLogs.hs +++ /dev/null @@ -1,66 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} -module Handler.ErrorLogs where - -import Data.Aeson ( (.:) - , FromJSON(parseJSON) - , withObject - ) -import Foundation ( Handler ) -import Model ( EntityField(ErrorLogRecordIncidents) - , ErrorLogRecord(ErrorLogRecord) - ) -import Startlude ( ($) - , Applicative(pure) - , Eq - , MonadIO(liftIO) - , Show - , Text - , Word32 - , getCurrentTime - , void - ) -import Yesod.Core ( requireCheckJsonBody ) -import Yesod.Persist ( (+=.) - , runDB - , upsert - ) - -data ErrorLog = ErrorLog - { errorLogEpoch :: !Text - , errorLogCommitHash :: !Text - , errorLogSourceFile :: !Text - , errorLogLine :: !Word32 - , errorLogTarget :: !Text - , errorLogLevel :: !Text - , errorLogMessage :: !Text - } - deriving (Eq, Show) - -instance FromJSON ErrorLog where - parseJSON = withObject "Error Log" $ \o -> do - errorLogEpoch <- o .: "log-epoch" - errorLogCommitHash <- o .: "commit-hash" - errorLogSourceFile <- o .: "file" - errorLogLine <- o .: "line" - errorLogLevel <- o .: "level" - errorLogTarget <- o .: "target" - errorLogMessage <- o .: "log-message" - pure ErrorLog { .. } - - -postErrorLogsR :: Handler () -postErrorLogsR = do - ErrorLog {..} <- requireCheckJsonBody @_ @ErrorLog - void $ runDB $ do - now <- liftIO getCurrentTime - let logRecord = ErrorLogRecord now - errorLogEpoch - errorLogCommitHash - errorLogSourceFile - errorLogLine - errorLogTarget - errorLogLevel - errorLogMessage - 1 - upsert logRecord [ErrorLogRecordIncidents +=. 1] diff --git a/src/Handler/Icons.hs b/src/Handler/Icons.hs deleted file mode 100644 index dacff3a..0000000 --- a/src/Handler/Icons.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} - -module Handler.Icons where - -import Data.Aeson (FromJSON, ToJSON) -import Startlude (Eq, Generic, Read, Show) - - -data IconType = PNG | JPG | JPEG | SVG - deriving (Eq, Show, Generic, Read) -instance ToJSON IconType -instance FromJSON IconType diff --git a/src/Handler/Marketplace.hs b/src/Handler/Marketplace.hs deleted file mode 100644 index d91b52a..0000000 --- a/src/Handler/Marketplace.hs +++ /dev/null @@ -1,306 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# 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 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)) - - -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) - - -getInfoR :: Handler (JSONResponse InfoRes) -getInfoR = do - 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 - 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 - } - - -getReleaseNotesR :: PkgId -> Handler ReleaseNotes -getReleaseNotesR pkg = do - 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 - - -getEosR :: Handler TypedContent -getEosR = do - spec <- getVersionSpecFromQuery - root <- getsYesod $ ( "eos") . resourcesDir . appSettings - subdirs <- listDirectory root - let (failures, successes) = partitionEithers $ Atto.parseOnly parseVersion . T.pack <$> subdirs - for_ failures $ \f -> $logWarn [i|Emver Parse Failure for EOS: #{f}|] - let mVersion = headMay . sortOn Down . filter (`satisfies` spec) $ successes - case mVersion of - Nothing -> sendResponseStatus status404 (NotFoundE [i|EOS version satisfying #{spec}|]) - Just version -> do - let imgPath = root show version "eos.img" - h <- runDB $ retrieveHash version imgPath - addHeader "x-eos-hash" h - respond typeOctet $ ContentFile imgPath Nothing - where - retrieveHash :: Version -> FilePath -> YesodDB RegistryCtx Text - retrieveHash v fp = do - mHash <- getBy (UniqueVersion v) - case mHash of - 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" "") - Just packages -> case eitherDecode $ LBS.fromStrict $ encodeUtf8 packages of - Left _ -> sendResponseStatus status400 (InvalidParamsE "get:ids" packages) - Right p -> do - 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 diff --git a/src/Handler/Package.hs b/src/Handler/Package.hs index 7790a8e..25847b6 100644 --- a/src/Handler/Package.hs +++ b/src/Handler/Package.hs @@ -1,14 +1,18 @@ 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 Handler.Package.V0.Icon qualified +import Handler.Package.V0.Index (PackageListRes, getPackageIndexR) +import Handler.Package.V0.Info (InfoRes, getInfoR) +import Handler.Package.V0.Instructions qualified +import Handler.Package.V0.Latest (VersionLatestRes, getVersionLatestR) +import Handler.Package.V0.License qualified +import Handler.Package.V0.Manifest qualified +import Handler.Package.V0.ReleaseNotes (ReleaseNotes, getReleaseNotesR) +import Handler.Package.V0.S9PK qualified +import Handler.Package.V0.Version (AppVersionRes, getPkgVersionR) +import Handler.Types.Api (ApiVersion (..)) +import Lib.Types.AppIndex (PkgId, S9PK) import Yesod.Core.Types ( JSONResponse, TypedContent, @@ -16,40 +20,40 @@ import Yesod.Core.Types ( getInfoR :: ApiVersion -> Handler (JSONResponse InfoRes) -getInfoR = _ +getInfoR _ = Handler.Package.V0.Info.getInfoR -getPackageListR :: ApiVersion -> Handler PackageListRes -getPackageListR = _ +getPackageIndexR :: ApiVersion -> Handler PackageListRes +getPackageIndexR _ = Handler.Package.V0.Index.getPackageIndexR getVersionLatestR :: ApiVersion -> Handler VersionLatestRes -getVersionLatestR = _ +getVersionLatestR _ = Handler.Package.V0.Latest.getVersionLatestR getAppR :: ApiVersion -> S9PK -> Handler TypedContent -getAppR = _ +getAppR _ = Handler.Package.V0.S9PK.getAppR getAppManifestR :: ApiVersion -> PkgId -> Handler TypedContent -getAppManifestR = _ +getAppManifestR _ = Handler.Package.V0.Manifest.getAppManifestR getReleaseNotesR :: ApiVersion -> PkgId -> Handler ReleaseNotes -getReleaseNotesR = _ +getReleaseNotesR _ = Handler.Package.V0.ReleaseNotes.getReleaseNotesR getIconsR :: ApiVersion -> PkgId -> Handler TypedContent -getIconsR = _ +getIconsR _ = Handler.Package.V0.Icon.getIconsR getLicenseR :: ApiVersion -> PkgId -> Handler TypedContent -getLicenseR = _ +getLicenseR _ = Handler.Package.V0.License.getLicenseR getInstructionsR :: ApiVersion -> PkgId -> Handler TypedContent -getInstructionsR = _ +getInstructionsR _ = Handler.Package.V0.Instructions.getInstructionsR getPkgVersionR :: ApiVersion -> PkgId -> Handler AppVersionRes -getPkgVersionR = _ +getPkgVersionR _ = Handler.Package.V0.Version.getPkgVersionR diff --git a/src/Handler/Package/V0/Index.hs b/src/Handler/Package/V0/Index.hs index 8e7fc34..fbc9779 100644 --- a/src/Handler/Package/V0/Index.hs +++ b/src/Handler/Package/V0/Index.hs @@ -3,28 +3,36 @@ module Handler.Package.V0.Index where -import Conduit (runConduit, (.|)) +import Conduit (concatMapC, dropC, mapC, mapMC, runConduit, sinkList, takeC, (.|)) import Control.Monad.Reader.Has (Functor (fmap), Has, Monad ((>>=)), MonadReader, ReaderT (runReaderT), ask) -import Data.Aeson (FromJSON (..), ToJSON (..), Value, decode, object, withObject, (.:), (.=)) +import Data.Aeson (FromJSON (..), ToJSON (..), Value, decode, eitherDecodeStrict, 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.List (lookup) +import Data.List.NonEmpty qualified as NE import Data.Text qualified as T -import Database.Marketplace (PackageMetadata (..), collateVersions, getPkgDependencyData, searchServices, zipDependencyVersions) -import Database.Persist (Entity (..), Key) +import Database.Marketplace (PackageMetadata (..), collateVersions, getCategoriesFor, getPkgDataSource, getPkgDependencyData, serviceQuerySource, zipDependencyVersions) +import Database.Persist (Key) import Database.Persist.Sql (SqlBackend) import Foundation (Handler, Route (InstructionsR, LicenseR)) +import Handler.Types.Api (ApiVersion (..)) +import Handler.Util (basicRender) +import Lib.Conduit (filterDependencyBestVersion, filterDependencyOsCompatible, selectLatestVersionFromSpec) import Lib.Error (S9Error (..)) import Lib.PkgRepository (PkgRepo, getIcon, getManifest) import Lib.Types.AppIndex (PkgId) -import Lib.Types.Emver (Version, VersionRange, parseRange, satisfies) +import Lib.Types.Emver (Version, VersionRange (..), parseRange, satisfies) import Model (Category (..), Key (..), PkgRecord (..), VersionRecord (..)) +import Network.HTTP.Types (status400) +import Protolude.Unsafe (unsafeFromJust) 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 Startlude (Applicative ((*>)), Bifunctor (second), Bool (..), ByteString, Either (..), Eq, Generic, Int, Maybe (..), MonadIO, Num ((*), (-)), Read, Show, Text, Traversable (traverse), catMaybes, const, encodeUtf8, filter, flip, fromMaybe, id, nonEmpty, pure, readMaybe, show, snd, ($), (&&&), (.), (<$>), (<&>)) +import UnliftIO (mapConcurrently) +import Yesod (MonadLogger, MonadResource, ToContent (..), ToTypedContent (..), YesodPersist (runDB), lookupGetParam, sendResponseStatus) import Yesod.Core (logWarn) @@ -108,8 +116,8 @@ data OrderArrangement = ASC | DESC deriving (Eq, Show, Read) -getPackageListR :: Handler PackageListRes -getPackageListR = do +getPackageIndexR :: Handler PackageListRes +getPackageIndexR = do osPredicate <- getOsVersionQuery <&> \case Nothing -> const True @@ -124,27 +132,39 @@ getPackageListR = do query <- T.strip . fromMaybe (packageListQuery defaults) <$> lookupGetParam "query" runDB $ runConduit $ - searchServices category query + serviceQuerySource category query + -- group conduit pipeline by pkg id .| collateVersions - .| zipCategories - -- empty list since there are no requested packages in this case - .| filterLatestVersionFromSpec [] - .| filterPkgOsCompatible osPredicate + -- filter out versions of apps that are incompatible with the OS predicate + .| mapC (second (filter (osPredicate . versionRecordOsVersion))) + -- prune empty version sets + .| concatMapC (\(pkgId, vs) -> (pkgId,) <$> nonEmpty vs) + -- grab the latest matching version if it exists + .| concatMapC (\(a, b) -> (a,b,) <$> (selectLatestVersionFromSpec (const Any) b)) + -- construct + .| mapMC (\(a, b, c) -> PackageMetadata a b (versionRecordNumber c) <$> getCategoriesFor a) -- 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' + let packageRanges = fromMaybe None . (flip lookup $ (packageReqId &&& packageReqVersion) <$> packages') runDB -- TODO could probably be better with sequenceConduits . runConduit - $ getPkgData (packageReqId <$> packages') + $ getPkgDataSource (packageReqId <$> packages') + -- group conduit pipeline by pkg id .| collateVersions - .| zipCategories - .| filterLatestVersionFromSpec vMap - .| filterPkgOsCompatible osPredicate + -- filter out versions of apps that are incompatible with the OS predicate + .| mapC (second (filter (osPredicate . versionRecordOsVersion))) + -- prune empty version sets + .| concatMapC (\(pkgId, vs) -> (pkgId,) <$> nonEmpty vs) + -- grab the latest matching version if it exists + .| concatMapC (\(a, b) -> (a,b,) <$> (selectLatestVersionFromSpec packageRanges b)) + -- construct + .| mapMC (\(a, b, c) -> PackageMetadata a b (versionRecordNumber c) <$> getCategoriesFor a) .| 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 @@ -165,7 +185,8 @@ getPackageListR = do Left _ -> do let e = InvalidParamsE "get:ids" ids - $logWarn (show e) sendResponseStatus status400 e + $logWarn (show e) + sendResponseStatus status400 e Right a -> pure a getCategoryQuery :: Handler (Maybe Text) getCategoryQuery = @@ -175,7 +196,8 @@ getPackageListR = do Nothing -> do let e = InvalidParamsE "get:category" c - $logWarn (show e) sendResponseStatus status400 e + $logWarn (show e) + sendResponseStatus status400 e Just t -> pure $ Just t getPageQuery :: Handler Int getPageQuery = @@ -185,7 +207,8 @@ getPackageListR = do Nothing -> do let e = InvalidParamsE "get:page" p - $logWarn (show e) sendResponseStatus status400 e + $logWarn (show e) + sendResponseStatus status400 e Just t -> pure $ case t of 0 -> 1 -- disallow page 0 so offset is not negative _ -> t @@ -197,7 +220,8 @@ getPackageListR = do Nothing -> do let e = InvalidParamsE "get:per-page" pp - $logWarn (show e) sendResponseStatus status400 e + $logWarn (show e) + sendResponseStatus status400 e Just l -> pure l getOsVersionQuery :: Handler (Maybe VersionRange) getOsVersionQuery = @@ -207,7 +231,8 @@ getPackageListR = do Left _ -> do let e = InvalidParamsE "get:eos-version-compat" osv - $logWarn (show e) sendResponseStatus status400 e + $logWarn (show e) + sendResponseStatus status400 e Right v -> pure $ Just v getPackageDependencies :: (MonadIO m, MonadLogger m) => @@ -225,13 +250,13 @@ getPackageListR = do 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 + let pkgVersions' = versionRecordNumber <$> pkgVersions + let pkgCategories' = 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) + pure (pkgId, pkgCategories', NE.toList pkgVersions', pkgVersion, res) constructPackageListApiRes :: (MonadResource m, MonadReader r m, Has AppSettings r, Has PkgRepo r) => ( Key PkgRecord @@ -255,8 +280,8 @@ getPackageListR = do { 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 + , packageResInstructions = basicRender $ InstructionsR V0 pkgId + , packageResLicense = basicRender $ LicenseR V0 pkgId , packageResVersions = pkgVersions , packageResDependencies = HM.fromList deps } diff --git a/src/Handler/Package/V0/Info.hs b/src/Handler/Package/V0/Info.hs index 672f09d..6b7d688 100644 --- a/src/Handler/Package/V0/Info.hs +++ b/src/Handler/Package/V0/Info.hs @@ -1,8 +1,13 @@ module Handler.Package.V0.Info where import Data.Aeson (ToJSON (..)) -import Startlude (Generic, Show, Text, (.)) -import Yesod (ToContent (..), ToTypedContent (..)) +import Database.Esqueleto.Experimental (Entity (..), asc, from, orderBy, select, table, (^.)) +import Foundation (Handler, RegistryCtx (..)) +import Model (Category (..), EntityField (..)) +import Settings (AppSettings (..)) +import Startlude (Generic, Show, Text, pure, ($), (.), (<$>)) +import Yesod (ToContent (..), ToTypedContent (..), YesodPersist (runDB), getsYesod) +import Yesod.Core.Types (JSONResponse (..)) data InfoRes = InfoRes @@ -15,3 +20,14 @@ instance ToContent InfoRes where toContent = toContent . toJSON instance ToTypedContent InfoRes where toTypedContent = toTypedContent . toJSON + + +getInfoR :: Handler (JSONResponse InfoRes) +getInfoR = do + 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 diff --git a/src/Handler/Package/V0/Latest.hs b/src/Handler/Package/V0/Latest.hs index 83dca3a..3f5e291 100644 --- a/src/Handler/Package/V0/Latest.hs +++ b/src/Handler/Package/V0/Latest.hs @@ -1,11 +1,19 @@ module Handler.Package.V0.Latest where -import Data.Aeson (ToJSON (..)) +import Data.Aeson (ToJSON (..), eitherDecode) +import Data.ByteString.Lazy qualified as LBS import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict qualified as HM +import Data.List (lookup) +import Database.Marketplace (fetchLatestApp) +import Foundation (Handler) +import Lib.Error (S9Error (..)) import Lib.Types.AppIndex (PkgId) import Lib.Types.Emver (Version) -import Startlude (Generic, Maybe, Show, (.)) -import Yesod (ToContent (..), ToTypedContent (..)) +import Model (Key (..), VersionRecord (..)) +import Network.HTTP.Types (status400) +import Startlude (Either (..), Generic, Maybe (..), Show, catMaybes, encodeUtf8, fst, pure, snd, traverse, ($), (.), (<$>)) +import Yesod (Entity (..), ToContent (..), ToTypedContent (..), YesodPersist (runDB), YesodRequest (reqGetParams), getRequest, sendResponseStatus) newtype VersionLatestRes = VersionLatestRes (HashMap PkgId (Maybe Version)) @@ -15,3 +23,26 @@ instance ToContent VersionLatestRes where toContent = toContent . toJSON instance ToTypedContent VersionLatestRes where toTypedContent = toTypedContent . toJSON + + +-- TODO refactor with conduit +getVersionLatestR :: Handler VersionLatestRes +getVersionLatestR = do + getParameters <- reqGetParams <$> getRequest + case lookup "ids" getParameters of + Nothing -> sendResponseStatus status400 (InvalidParamsE "get:ids" "") + Just packages -> case eitherDecode $ LBS.fromStrict $ encodeUtf8 packages of + Left _ -> sendResponseStatus status400 (InvalidParamsE "get:ids" packages) + Right p -> do + 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 diff --git a/src/Handler/Package/V0/License.hs b/src/Handler/Package/V0/License.hs index 12fae57..35221f9 100644 --- a/src/Handler/Package/V0/License.hs +++ b/src/Handler/Package/V0/License.hs @@ -2,11 +2,16 @@ module Handler.Package.V0.License where +import Conduit (awaitForever, (.|)) import Data.String.Interpolate.IsString (i) import Foundation (Handler) -import Handler.Util (getVersionSpecFromQuery) +import Handler.Util (getVersionSpecFromQuery, orThrow, versionPriorityFromQueryIsMin) +import Lib.Error (S9Error (..)) +import Lib.PkgRepository (getBestVersion, getLicense) import Lib.Types.AppIndex (PkgId) -import Yesod (TypedContent) +import Network.HTTP.Types (status400) +import Startlude (show, ($)) +import Yesod (TypedContent, addHeader, respondSource, sendChunkBS, sendResponseStatus, typePlain) getLicenseR :: PkgId -> Handler TypedContent diff --git a/src/Handler/Package/V0/Manifest.hs b/src/Handler/Package/V0/Manifest.hs index d578952..e0a543a 100644 --- a/src/Handler/Package/V0/Manifest.hs +++ b/src/Handler/Package/V0/Manifest.hs @@ -1 +1,27 @@ +{-# LANGUAGE QuasiQuotes #-} + module Handler.Package.V0.Manifest where + +import Conduit (awaitForever, (.|)) +import Data.String.Interpolate.IsString (i) +import Foundation (Handler) +import Handler.Util (addPackageHeader, getVersionSpecFromQuery, orThrow, versionPriorityFromQueryIsMin) +import Lib.Error (S9Error (..)) +import Lib.PkgRepository (getBestVersion, getManifest) +import Lib.Types.AppIndex (PkgId) +import Network.HTTP.Types (status404) +import Startlude (show, ($)) +import Yesod (TypedContent, addHeader, respondSource, sendChunkBS, sendResponseStatus, typeJson) + + +getAppManifestR :: PkgId -> Handler TypedContent +getAppManifestR pkg = do + versionSpec <- getVersionSpecFromQuery + 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 \ No newline at end of file diff --git a/src/Handler/Package/V0/ReleaseNotes.hs b/src/Handler/Package/V0/ReleaseNotes.hs index 60f94e0..168301e 100644 --- a/src/Handler/Package/V0/ReleaseNotes.hs +++ b/src/Handler/Package/V0/ReleaseNotes.hs @@ -2,12 +2,16 @@ module Handler.Package.V0.ReleaseNotes where -import Data.Aeson (ToJSON (..), Value (..), object, (.=)) +import Data.Aeson (ToJSON (..)) import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict qualified as HM +import Database.Marketplace (fetchAllAppVersions) +import Foundation (Handler, RegistryCtx (..)) +import Lib.Types.AppIndex (PkgId) import Lib.Types.Emver (Version) -import Startlude (Eq, Show, Text, (.)) -import Yesod (ToContent (..), ToTypedContent (..)) +import Model (VersionRecord (..)) +import Startlude (Down (..), Eq, Show, Text, fst, pure, sortOn, ($), (&&&), (.), (<$>)) +import Yesod (ToContent (..), ToTypedContent (..), YesodPersist (runDB), getYesod) newtype ReleaseNotes = ReleaseNotes {unReleaseNotes :: HashMap Version Text} @@ -18,3 +22,18 @@ instance ToContent ReleaseNotes where toContent = toContent . toJSON instance ToTypedContent ReleaseNotes where toTypedContent = toTypedContent . toJSON + + +getReleaseNotesR :: PkgId -> Handler ReleaseNotes +getReleaseNotesR pkg = do + 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 diff --git a/src/Handler/Package/V0/S9PK.hs b/src/Handler/Package/V0/S9PK.hs index b240255..94325c6 100644 --- a/src/Handler/Package/V0/S9PK.hs +++ b/src/Handler/Package/V0/S9PK.hs @@ -1 +1,56 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + module Handler.Package.V0.S9PK where + +import Data.String.Interpolate.IsString (i) +import Data.Text qualified as T +import Database.Queries (createMetric, fetchApp, fetchAppVersion) +import Foundation (Handler) +import GHC.Show (show) +import Handler.Util (addPackageHeader, getVersionSpecFromQuery, orThrow, versionPriorityFromQueryIsMin) +import Lib.Error (S9Error (..)) +import Lib.PkgRepository (getBestVersion, getPackage) +import Lib.Types.AppIndex (PkgId (..), S9PK) +import Lib.Types.Emver (Version (..)) +import Network.HTTP.Types (status404) +import Startlude (Maybe (..), pure, void, ($), (.), (>>=)) +import System.FilePath (takeBaseName) +import Yesod (Content (..), TypedContent, YesodPersist (runDB), notFound, respond, sendResponseStatus, typeOctet) +import Yesod.Core (logError) + + +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}|]) + addPackageHeader pkg version + void $ recordMetrics pkg version + pkgPath <- + getPackage pkg version >>= \case + Nothing -> sendResponseStatus status404 (NotFoundE [i|#{pkg}@#{version}|]) + Just a -> pure a + respond typeOctet $ ContentFile pkgPath Nothing + + +recordMetrics :: PkgId -> Version -> Handler () +recordMetrics pkg appVersion = do + sa <- runDB $ fetchApp pkg + case sa of + Nothing -> + do + $logError [i|#{pkg} not found in database|] + notFound + Just _ -> do + existingVersion <- runDB $ fetchAppVersion pkg appVersion + case existingVersion of + Nothing -> + do + $logError [i|#{pkg}@#{appVersion} not found in database|] + notFound + Just _ -> runDB $ createMetric pkg appVersion \ No newline at end of file diff --git a/src/Handler/Package/V0/Version.hs b/src/Handler/Package/V0/Version.hs index 79a5f4b..90fbc1c 100644 --- a/src/Handler/Package/V0/Version.hs +++ b/src/Handler/Package/V0/Version.hs @@ -1 +1,46 @@ +{-# LANGUAGE QuasiQuotes #-} + module Handler.Package.V0.Version where + +import Data.Aeson (ToJSON, object, (.=)) +import Data.String.Interpolate.IsString (i) +import Foundation (Handler) +import Handler.Util ( + getVersionSpecFromQuery, + orThrow, + versionPriorityFromQueryIsMin, + ) +import Lib.Error (S9Error (..)) +import Lib.PkgRepository (getBestVersion) +import Lib.Types.AppIndex (PkgId) +import Lib.Types.Emver (Version (..)) +import Network.HTTP.Types (status404) +import Startlude (Eq, Maybe, Show, (.), (<$>)) +import Yesod (ToContent (..), ToTypedContent, sendResponseStatus) +import Yesod.Core (ToJSON (..), ToTypedContent (..)) + + +newtype AppVersionRes = AppVersionRes + { appVersionVersion :: Version + } + deriving (Eq, Show) +instance ToJSON AppVersionRes where + toJSON AppVersionRes{appVersionVersion} = object ["version" .= appVersionVersion] +instance ToContent AppVersionRes where + toContent = toContent . toJSON +instance ToTypedContent AppVersionRes where + toTypedContent = toTypedContent . toJSON +instance ToContent (Maybe AppVersionRes) where + toContent = toContent . toJSON +instance ToTypedContent (Maybe AppVersionRes) where + toTypedContent = toTypedContent . toJSON + + +getPkgVersionR :: PkgId -> Handler AppVersionRes +getPkgVersionR pkg = do + spec <- getVersionSpecFromQuery + preferMin <- versionPriorityFromQueryIsMin + AppVersionRes <$> getBestVersion pkg spec preferMin + `orThrow` sendResponseStatus + status404 + (NotFoundE [i|Version for #{pkg} satisfying #{spec}|]) \ No newline at end of file diff --git a/src/Handler/Types/Api.hs b/src/Handler/Types/Api.hs index f540b68..e04d67e 100644 --- a/src/Handler/Types/Api.hs +++ b/src/Handler/Types/Api.hs @@ -1,24 +1,31 @@ module Handler.Types.Api where -import GHC.Read ( Read(..) ) -import GHC.Show ( show ) -import Startlude ( Eq - , Maybe(..) - , Ord - , Read - , Show - ) -import Yesod ( PathPiece(..) ) +import GHC.Read (Read (..)) +import GHC.Show (show) +import Startlude ( + Eq, + Maybe (..), + Ord, + Show, + ) +import Yesod (PathPiece (..)) + data ApiVersion = V0 - | V1 deriving (Eq, Ord) + | V1 + deriving (Eq, Ord) + instance Show ApiVersion where show V0 = "v0" show V1 = "v1" + + instance Read ApiVersion where - readsPrec = _ + readsPrec _ "v0" = [(V0, "")] + readsPrec _ "v1" = [(V1, "")] + readsPrec _ _ = [] instance PathPiece ApiVersion where @@ -26,4 +33,4 @@ instance PathPiece ApiVersion where toPathPiece V1 = "v1" fromPathPiece "v0" = Just V0 fromPathPiece "v1" = Just V1 - fromPathPiece _ = Nothing + fromPathPiece _ = Nothing diff --git a/src/Handler/Types/Status.hs b/src/Handler/Types/Status.hs deleted file mode 100644 index a8514c0..0000000 --- a/src/Handler/Types/Status.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} -{-# HLINT ignore "Use newtype instead of data" #-} -module Handler.Types.Status where - -import Startlude ( (.) - , Eq - , Maybe - , Show - ) - -import Data.Aeson ( KeyValue((.=)) - , ToJSON(toJSON) - , object - ) -import Yesod.Core.Content ( ToContent(..) - , ToTypedContent(..) - ) - -import Lib.Types.Emver ( Version ) -import Orphans.Emver ( ) - -newtype AppVersionRes = AppVersionRes - { appVersionVersion :: Version - } - deriving (Eq, Show) -instance ToJSON AppVersionRes where - toJSON AppVersionRes { appVersionVersion } = object ["version" .= appVersionVersion] -instance ToContent AppVersionRes where - toContent = toContent . toJSON -instance ToTypedContent AppVersionRes where - toTypedContent = toTypedContent . toJSON -instance ToContent (Maybe AppVersionRes) where - toContent = toContent . toJSON -instance ToTypedContent (Maybe AppVersionRes) where - toTypedContent = toTypedContent . toJSON diff --git a/src/Handler/Util.hs b/src/Handler/Util.hs index 8a5efbf..0eb9625 100644 --- a/src/Handler/Util.hs +++ b/src/Handler/Util.hs @@ -1,16 +1,20 @@ +{-# LANGUAGE QuasiQuotes #-} + module Handler.Util where import Control.Monad.Reader.Has ( Has, MonadReader, ) +import Data.Attoparsec.Text (Parser, parseOnly) +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 Lib.PkgRepository (PkgRepo, getHash) import Lib.Types.AppIndex (PkgId) import Lib.Types.Emver ( - Version (Version), + Version, VersionRange, ) import Network.HTTP.Types ( @@ -19,29 +23,35 @@ import Network.HTTP.Types ( ) import Startlude ( Bool (..), + Either (..), Foldable (foldMap), Maybe (..), + Monoid (..), Semigroup ((<>)), Text, + decodeUtf8, fromMaybe, + fst, isSpace, not, pure, readMaybe, + ($), (.), (<$>), - (>>=),, ($) + (>>=), ) import UnliftIO (MonadUnliftIO) import Yesod ( MonadHandler, - RenderRoute (Route), + RenderRoute (..), TypedContent (..), lookupGetParam, sendResponseStatus, toContent, typePlain, ) +import Yesod.Core (addHeader) orThrow :: MonadHandler m => m (Maybe a) -> m a -> m a @@ -80,4 +90,14 @@ addPackageHeader pkg version = do 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 +basicRender = TL.toStrict . TB.toLazyText . foldMap (mappend (TB.singleton '/') . TB.fromText) . fst . renderRoute + + +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 -> + sendResponseText status400 [i|Invalid Request! The query parameter '#{k}' failed to parse: #{e}|] + Right a -> pure (Just a) diff --git a/src/Handler/Version.hs b/src/Handler/Version.hs deleted file mode 100644 index 173a8e3..0000000 --- a/src/Handler/Version.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} - -module Handler.Version where - -import Startlude ( (<$>) ) - -import Yesod.Core ( sendResponseStatus ) - -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 - , versionPriorityFromQueryIsMin - ) - -getPkgVersionR :: PkgId -> Handler AppVersionRes -getPkgVersionR pkg = do - spec <- getVersionSpecFromQuery - preferMin <- versionPriorityFromQueryIsMin - AppVersionRes <$> getBestVersion pkg spec preferMin `orThrow` sendResponseStatus - status404 - (NotFoundE [i|Version for #{pkg} satisfying #{spec}|]) diff --git a/src/Lib/Conduit.hs b/src/Lib/Conduit.hs index ab4cbf6..5e79d29 100644 --- a/src/Lib/Conduit.hs +++ b/src/Lib/Conduit.hs @@ -3,52 +3,27 @@ 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.List.NonEmpty qualified as NE import Data.String.Interpolate.IsString (i) -import Database.Marketplace (PackageDependencyMetadata (..), PackageMetadata (..)) +import Database.Marketplace (PackageDependencyMetadata (..)) import Database.Persist (Entity (..)) +import Lib.Ord (maximumOn) 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, ($), (.)) +import Lib.Types.Emver (Version, VersionRange (..), satisfies, (<||)) +import Model (Key (..), PkgDependency (..), PkgRecord (..), VersionRecord (..)) +import Startlude (Bool, Down (..), Maybe (..), NonEmpty, Text, filter, headMay, pure, sortOn, ($), (.), (<$>)) -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 - } +selectLatestVersionFromSpec :: + (PkgId -> VersionRange) -> + NonEmpty VersionRecord -> + Maybe VersionRecord +selectLatestVersionFromSpec pkgRanges vs = + let pkgId = NE.head $ versionRecordPkgId <$> vs + spec = pkgRanges (unPkgRecordKey pkgId) + in headMay . sortOn (Down . versionRecordNumber) $ NE.filter ((`satisfies` spec) . versionRecordNumber) vs filterDependencyOsCompatible :: (Version -> Bool) -> PackageDependencyMetadata -> PackageDependencyMetadata diff --git a/src/Lib/Registry.hs b/src/Lib/Registry.hs deleted file mode 100644 index c2548dc..0000000 --- a/src/Lib/Registry.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - -module Lib.Registry where - -import Startlude ( ($) - , (.) - , ConvertText(toS) - , Eq((==)) - , KnownSymbol - , Proxy(Proxy) - , Read - , Show - , String - , Symbol - , readMaybe - , show - , symbolVal - ) - -import qualified GHC.Read ( Read(..) ) -import qualified GHC.Show ( Show(..) ) -import System.FilePath ( (<.>) - , splitExtension - ) -import Yesod.Core ( PathPiece(..) ) - -newtype Extension (a :: Symbol) = Extension String deriving (Eq) -type S9PK = Extension "s9pk" - -extension :: KnownSymbol a => Extension a -> String -extension = symbolVal - -instance KnownSymbol a => Show (Extension a) where - show e@(Extension file) = file <.> extension e - -instance KnownSymbol a => Read (Extension a) where - readsPrec _ s = case symbolVal $ Proxy @a of - "" -> [(Extension s, "")] - other -> [ (Extension file, "") | ext' == "" <.> other ] - where (file, ext') = splitExtension s - -instance KnownSymbol a => PathPiece (Extension a) where - fromPathPiece = readMaybe . toS - toPathPiece = show diff --git a/src/Lib/Types/AppIndex.hs b/src/Lib/Types/AppIndex.hs index 4ab7953..0eb8de4 100644 --- a/src/Lib/Types/AppIndex.hs +++ b/src/Lib/Types/AppIndex.hs @@ -1,46 +1,57 @@ -{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralisedNewtypeDeriving #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} + module Lib.Types.AppIndex where -import Startlude +import Startlude -- NOTE: leave eitherDecode for inline test evaluation below -import Control.Monad ( fail ) -import Data.Aeson ( (.:) - , (.:?) - , FromJSON(..) - , FromJSONKey(..) - , ToJSON(..) - , ToJSONKey(..) - , withObject - ) -import qualified Data.ByteString.Lazy as BS -import Data.Functor.Contravariant ( contramap ) -import qualified Data.HashMap.Strict as HM -import Data.String.Interpolate.IsString - ( i ) -import qualified Data.Text as T -import Database.Persist ( PersistField(..) - , PersistValue(PersistText) - , SqlType(..) - ) -import Database.Persist.Sql ( PersistFieldSql(sqlType) ) -import GHC.Read ( Read(readsPrec) ) -import Lib.Types.Emver ( Version - , VersionRange - ) -import Orphans.Emver ( ) -import qualified Protolude.Base as P - ( Show(..) ) -import Web.HttpApiData ( FromHttpApiData - , ToHttpApiData - ) -import Yesod ( PathPiece(..) ) -newtype PkgId = PkgId { unPkgId :: Text } +import Control.Monad (fail) +import Data.Aeson ( + FromJSON (..), + FromJSONKey (..), + ToJSON (..), + ToJSONKey (..), + withObject, + (.:), + (.:?), + ) +import Data.ByteString.Lazy qualified as BS +import Data.Functor.Contravariant (contramap) +import Data.HashMap.Strict qualified as HM +import Data.String.Interpolate.IsString ( + i, + ) +import Data.Text qualified as T +import Database.Persist ( + PersistField (..), + PersistValue (PersistText), + SqlType (..), + ) +import Database.Persist.Sql (PersistFieldSql (sqlType)) +import GHC.Read (Read (readsPrec)) +import Lib.Types.Emver ( + Version, + VersionRange, + ) +import Orphans.Emver () +import Protolude.Base qualified as P ( + Show (..), + ) +import System.FilePath (splitExtension, (<.>)) +import Web.HttpApiData ( + FromHttpApiData, + ToHttpApiData, + ) +import Yesod (PathPiece (..)) + + +newtype PkgId = PkgId {unPkgId :: Text} deriving stock (Eq, Ord) deriving newtype (FromHttpApiData, ToHttpApiData) instance IsString PkgId where @@ -62,72 +73,100 @@ instance ToJSONKey PkgId where instance PersistField PkgId where toPersistValue = PersistText . show fromPersistValue (PersistText t) = Right . PkgId $ toS t - fromPersistValue other = Left [i|Invalid AppId: #{other}|] + fromPersistValue other = Left [i|Invalid AppId: #{other}|] instance PersistFieldSql PkgId where sqlType _ = SqlString instance PathPiece PkgId where fromPathPiece = fmap PkgId . fromPathPiece - toPathPiece = unPkgId + toPathPiece = unPkgId data VersionInfo = VersionInfo - { versionInfoVersion :: !Version + { versionInfoVersion :: !Version , versionInfoReleaseNotes :: !Text , versionInfoDependencies :: !(HM.HashMap PkgId VersionRange) - , versionInfoOsVersion :: !Version + , versionInfoOsVersion :: !Version , versionInfoInstallAlert :: !(Maybe Text) } deriving (Eq, Show) + data PackageDependency = PackageDependency - { packageDependencyOptional :: !(Maybe Text) - , packageDependencyVersion :: !VersionRange + { packageDependencyOptional :: !(Maybe Text) + , packageDependencyVersion :: !VersionRange , packageDependencyDescription :: !(Maybe Text) } - deriving Show + deriving (Show) instance FromJSON PackageDependency where parseJSON = withObject "service dependency info" $ \o -> do - packageDependencyOptional <- o .:? "optional" - packageDependencyVersion <- o .: "version" + packageDependencyOptional <- o .:? "optional" + packageDependencyVersion <- o .: "version" packageDependencyDescription <- o .:? "description" - pure PackageDependency { .. } + pure PackageDependency{..} data ServiceAlert = INSTALL | UNINSTALL | RESTORE | START | STOP deriving (Show, Eq, Generic, Hashable, Read) data PackageManifest = PackageManifest - { packageManifestId :: !PkgId - , packageManifestTitle :: !Text - , packageManifestVersion :: !Version - , packageManifestDescriptionLong :: !Text + { packageManifestId :: !PkgId + , packageManifestTitle :: !Text + , packageManifestVersion :: !Version + , packageManifestDescriptionLong :: !Text , packageManifestDescriptionShort :: !Text - , packageManifestReleaseNotes :: !Text - , packageManifestIcon :: !(Maybe Text) - , packageManifestAlerts :: !(HM.HashMap ServiceAlert (Maybe Text)) - , packageManifestDependencies :: !(HM.HashMap PkgId PackageDependency) - , packageManifestEosVersion :: !Version + , packageManifestReleaseNotes :: !Text + , packageManifestIcon :: !(Maybe Text) + , packageManifestAlerts :: !(HM.HashMap ServiceAlert (Maybe Text)) + , packageManifestDependencies :: !(HM.HashMap PkgId PackageDependency) + , packageManifestEosVersion :: !Version } - deriving Show + deriving (Show) instance FromJSON PackageManifest where parseJSON = withObject "service manifest" $ \o -> do - packageManifestId <- o .: "id" - packageManifestTitle <- o .: "title" - packageManifestVersion <- o .: "version" - packageManifestDescriptionLong <- o .: "description" >>= (.: "long") + packageManifestId <- o .: "id" + packageManifestTitle <- o .: "title" + packageManifestVersion <- o .: "version" + packageManifestDescriptionLong <- o .: "description" >>= (.: "long") packageManifestDescriptionShort <- o .: "description" >>= (.: "short") - packageManifestIcon <- o .: "assets" >>= (.: "icon") - packageManifestReleaseNotes <- o .: "release-notes" - alerts <- o .: "alerts" - a <- for (HM.toList alerts) $ \(key, value) -> do + packageManifestIcon <- o .: "assets" >>= (.: "icon") + packageManifestReleaseNotes <- o .: "release-notes" + alerts <- o .: "alerts" + a <- for (HM.toList alerts) $ \(key, value) -> do alertType <- case readMaybe $ T.toUpper key of Nothing -> fail "could not parse alert key as ServiceAlert" - Just t -> pure t + Just t -> pure t alertDesc <- parseJSON value pure (alertType, alertDesc) let packageManifestAlerts = HM.fromList a packageManifestDependencies <- o .: "dependencies" - packageManifestEosVersion <- o .: "eos-version" - pure PackageManifest { .. } + packageManifestEosVersion <- o .: "eos-version" + pure PackageManifest{..} + + +newtype Extension (a :: Symbol) = Extension String deriving (Eq) +type S9PK = Extension "s9pk" + + +extension :: KnownSymbol a => Extension a -> String +extension = symbolVal + + +instance KnownSymbol a => Show (Extension a) where + show e@(Extension file) = file <.> extension e + + +instance KnownSymbol a => Read (Extension a) where + readsPrec _ s = case symbolVal $ Proxy @a of + "" -> [(Extension s, "")] + other -> [(Extension file, "") | ext' == "" <.> other] + where + (file, ext') = splitExtension s + + +instance KnownSymbol a => PathPiece (Extension a) where + fromPathPiece = readMaybe . toS + toPathPiece = show + -- >>> eitherDecode testManifest :: Either String PackageManifest testManifest :: BS.ByteString -testManifest = [i|{ +testManifest = + [i|{ "id": "embassy-pages", "title": "Embassy Pages", "version": "0.1.3",