From dbd73fae7f87886b1a7ce5a31df0121fc8508577 Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Mon, 20 Jun 2022 10:28:28 -0600 Subject: [PATCH] Feature/api versioning (#106) * wip * finishes initial refactor * prune unused code * finished massive refactor * remove commented deps * fix import * fix bug --- .gitignore | 4 +- Makefile | 2 + config/routes | 23 +- fourmolu.yaml | 8 + package.yaml | 9 +- src/Application.hs | 667 +++++++++++++------------ src/Cli/Cli.hs | 647 +++++++++++++----------- src/Database/Marketplace.hs | 225 --------- src/Database/Queries.hs | 303 +++++++++-- src/Foundation.hs | 394 ++++++++------- src/Handler/Admin.hs | 345 +++++++------ src/Handler/Apps.hs | 113 ----- src/Handler/Eos.hs | 5 + src/Handler/Eos/V0/EosImg.hs | 53 ++ src/Handler/Eos/V0/Latest.hs | 65 +++ src/Handler/ErrorLogs.hs | 66 --- src/Handler/Icons.hs | 80 --- src/Handler/Marketplace.hs | 451 ----------------- src/Handler/Package.hs | 59 +++ src/Handler/Package/V0/Icon.hs | 32 ++ src/Handler/Package/V0/Index.hs | 302 +++++++++++ src/Handler/Package/V0/Info.hs | 33 ++ src/Handler/Package/V0/Instructions.hs | 26 + src/Handler/Package/V0/Latest.hs | 48 ++ src/Handler/Package/V0/License.hs | 26 + src/Handler/Package/V0/Manifest.hs | 27 + src/Handler/Package/V0/ReleaseNotes.hs | 39 ++ src/Handler/Package/V0/S9PK.hs | 49 ++ src/Handler/Package/V0/Version.hs | 46 ++ src/Handler/Types/Api.hs | 36 ++ src/Handler/Types/Marketplace.hs | 163 ------ src/Handler/Types/Status.hs | 37 -- src/Handler/Util.hs | 103 ++++ src/Handler/Version.hs | 32 -- src/Lib/External/AppMgr.hs | 222 ++++---- src/Lib/PkgRepository.hs | 473 ++++++++++-------- src/Lib/Registry.hs | 47 -- src/Lib/Types/AppIndex.hs | 267 ---------- src/Lib/Types/Core.hs | 108 ++++ src/Lib/Types/Manifest.hs | 211 ++++++++ src/Model.hs | 71 +-- src/Startlude.hs | 72 ++- src/Util/Shared.hs | 171 ------- stack.yaml | 10 +- 44 files changed, 3115 insertions(+), 3055 deletions(-) create mode 100644 fourmolu.yaml delete mode 100644 src/Database/Marketplace.hs delete mode 100644 src/Handler/Apps.hs create mode 100644 src/Handler/Eos.hs create mode 100644 src/Handler/Eos/V0/EosImg.hs create mode 100644 src/Handler/Eos/V0/Latest.hs delete mode 100644 src/Handler/ErrorLogs.hs delete mode 100644 src/Handler/Icons.hs delete mode 100644 src/Handler/Marketplace.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 delete mode 100644 src/Handler/Types/Status.hs create mode 100644 src/Handler/Util.hs delete mode 100644 src/Handler/Version.hs delete mode 100644 src/Lib/Registry.hs delete mode 100644 src/Lib/Types/AppIndex.hs create mode 100644 src/Lib/Types/Core.hs create mode 100644 src/Lib/Types/Manifest.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..e114134 100644 --- a/config/routes +++ b/config/routes @@ -3,19 +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 - --- SUPPORT API V0 -/support/v0/error-logs ErrorLogsR POST +/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 -- ADMIN API V0 /admin/v0/upload PkgUploadR POST !admin 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..bd31bdc 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -1,215 +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.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 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 @@ -218,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 @@ -239,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 @@ -253,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 @@ -265,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 @@ -276,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 @@ -355,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 @@ -398,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 @@ -450,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 --------------------------------------------- @@ -504,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/Cli/Cli.hs b/src/Cli/Cli.hs index c2ab054..ccf33e6 100644 --- a/src/Cli/Cli.hs +++ b/src/Cli/Cli.hs @@ -8,199 +8,217 @@ {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} -module Cli.Cli - ( cliMain - ) where +module Cli.Cli ( + cliMain, +) where + +import Conduit ( + foldC, + runConduit, + (.|), + ) +import Control.Monad.Logger ( + LogLevel (..), + MonadLogger (monadLoggerLog), + MonadLoggerIO (askLoggerIO), + ToLogStr, + fromLogStr, + toLogStr, + ) +import Crypto.Hash ( + SHA256 (SHA256), + hashWith, + ) +import Data.Aeson ( + ToJSON, + eitherDecodeStrict, + ) +import Data.ByteArray.Encoding ( + Base (..), + convertToBase, + ) +import Data.ByteString.Char8 qualified as B8 +import Data.ByteString.Lazy qualified as LB +import Data.Conduit.Process (readProcess) +import Data.Default +import Data.Functor.Contravariant (contramap) +import Data.HashMap.Internal.Strict ( + HashMap, + delete, + empty, + insert, + lookup, + traverseWithKey, + ) +import Data.String.Interpolate.IsString ( + i, + ) +import Data.Text (toLower) +import Dhall ( + Encoder (embed), + FromDhall (..), + Generic, + ToDhall (..), + auto, + inject, + inputFile, + ) +import Dhall.Core (pretty) +import Handler.Admin ( + AddCategoryReq (AddCategoryReq), + IndexPkgReq (IndexPkgReq), + PackageList (..), + ) +import Lib.External.AppMgr (sourceManifest) +import Lib.Types.Core ( + PkgId (..), + ) +import Lib.Types.Emver (Version (..)) +import Lib.Types.Manifest (PackageManifest (..)) +import Network.HTTP.Client.Conduit ( + StreamFileStatus (StreamFileStatus, fileSize, readSoFar), + applyBasicAuth, + httpLbs, + observedStreamFile, + ) +import Network.HTTP.Client.TLS (newTlsManager) +import Network.HTTP.Simple ( + getResponseBody, + getResponseStatus, + httpJSON, + httpLBS, + parseRequest, + setRequestBody, + setRequestBodyJSON, + setRequestHeaders, + ) +import Network.HTTP.Types (status200) +import Network.URI ( + URI, + parseURI, + ) +import Options.Applicative ( + Alternative ((<|>)), + Applicative (liftA2, pure, (<*>)), + Parser, + ParserInfo, + auto, + command, + execParser, + fullDesc, + help, + helper, + info, + liftA3, + long, + mappend, + metavar, + option, + optional, + progDesc, + short, + strArgument, + strOption, + subparser, + switch, + (<$>), + (<**>), + ) +import Rainbow ( + Chunk, + Radiant, + blue, + chunk, + fore, + green, + magenta, + putChunk, + putChunkLn, + red, + white, + yellow, + ) +import Startlude ( + Bool (..), + ConvertText (toS), + Either (..), + Eq (..), + ExitCode (..), + FilePath, + IO, + Int, + IsString (..), + Maybe (..), + Monad ((>>=)), + ReaderT (runReaderT), + Semigroup ((<>)), + Show, + String, + appendFile, + const, + decodeUtf8, + exitWith, + filter, + flip, + fmap, + for, + for_, + fromIntegral, + fromMaybe, + fst, + headMay, + not, + panic, + show, + snd, + unlessM, + void, + when, + writeFile, + zip, + ($), + ($>), + (&), + (.), + (<&>), + ) +import System.Directory ( + createDirectoryIfMissing, + doesPathExist, + getCurrentDirectory, + getFileSize, + getHomeDirectory, + listDirectory, + ) +import System.FilePath ( + takeDirectory, + takeExtension, + (), + ) +import System.ProgressBar ( + Progress (..), + defStyle, + newProgressBar, + updateProgress, + ) +import Yesod ( + logError, + logWarn, + ) -import Conduit ( (.|) - , foldC - , runConduit - ) -import Control.Monad.Logger ( LogLevel(..) - , MonadLogger(monadLoggerLog) - , MonadLoggerIO(askLoggerIO) - , ToLogStr - , fromLogStr - , toLogStr - ) -import Crypto.Hash ( SHA256(SHA256) - , hashWith - ) -import Data.Aeson ( ToJSON - , eitherDecodeStrict - ) -import Data.ByteArray.Encoding ( Base(..) - , convertToBase - ) -import qualified Data.ByteString.Char8 as B8 -import qualified Data.ByteString.Lazy as LB -import Data.Conduit.Process ( readProcess ) -import Data.Default -import Data.Functor.Contravariant ( contramap ) -import Data.HashMap.Internal.Strict ( HashMap - , delete - , empty - , insert - , lookup - , traverseWithKey - ) -import Data.String.Interpolate.IsString - ( i ) -import Data.Text ( toLower ) -import Dhall ( Encoder(embed) - , FromDhall(..) - , Generic - , ToDhall(..) - , auto - , inject - , inputFile - ) -import Dhall.Core ( pretty ) -import Handler.Admin ( AddCategoryReq(AddCategoryReq) - , IndexPkgReq(IndexPkgReq) - , PackageList(..) - ) -import Lib.External.AppMgr ( sourceManifest ) -import Lib.Types.AppIndex ( PackageManifest - ( PackageManifest - , packageManifestId - , packageManifestVersion - ) - , PkgId(..) - ) -import Lib.Types.Emver ( Version(..) ) -import Network.HTTP.Client.Conduit ( StreamFileStatus(StreamFileStatus, fileSize, readSoFar) - , applyBasicAuth - , httpLbs - , observedStreamFile - ) -import Network.HTTP.Client.TLS ( newTlsManager ) -import Network.HTTP.Simple ( getResponseBody - , getResponseStatus - , httpJSON - , httpLBS - , parseRequest - , setRequestBody - , setRequestBodyJSON - , setRequestHeaders - ) -import Network.HTTP.Types ( status200 ) -import Network.URI ( URI - , parseURI - ) -import Options.Applicative ( (<$>) - , (<**>) - , Alternative((<|>)) - , Applicative((<*>), liftA2, pure) - , Parser - , ParserInfo - , auto - , command - , execParser - , fullDesc - , help - , helper - , info - , liftA3 - , long - , mappend - , metavar - , option - , optional - , progDesc - , short - , strArgument - , strOption - , subparser - , switch - ) -import Rainbow ( Chunk - , Radiant - , blue - , chunk - , fore - , green - , magenta - , putChunk - , putChunkLn - , red - , white - , yellow - ) -import Startlude ( ($) - , ($>) - , (&) - , (.) - , (<&>) - , Bool(..) - , ConvertText(toS) - , Either(..) - , Eq(..) - , ExitCode(..) - , FilePath - , IO - , Int - , IsString(..) - , Maybe(..) - , Monad((>>=)) - , ReaderT(runReaderT) - , Semigroup((<>)) - , Show - , String - , appendFile - , const - , decodeUtf8 - , exitWith - , filter - , flip - , fmap - , for - , for_ - , fromIntegral - , fromMaybe - , fst - , headMay - , not - , panic - , show - , snd - , unlessM - , void - , when - , writeFile - , zip - ) -import System.Directory ( createDirectoryIfMissing - , doesPathExist - , getCurrentDirectory - , getFileSize - , getHomeDirectory - , listDirectory - ) -import System.FilePath ( () - , takeDirectory - , takeExtension - ) -import System.ProgressBar ( Progress(..) - , defStyle - , newProgressBar - , updateProgress - ) -import Yesod ( logError - , logWarn - ) data Upload = Upload { publishRepoName :: !String - , publishPkg :: !(Maybe FilePath) - , publishIndex :: !Bool + , publishPkg :: !(Maybe FilePath) + , publishIndex :: !Bool } - deriving Show + deriving (Show) + newtype PublishCfg = PublishCfg { publishCfgRepos :: HashMap String PublishCfgRepo } - deriving Generic + deriving (Generic) instance FromDhall PublishCfg instance ToDhall PublishCfg instance Default PublishCfg where @@ -209,23 +227,27 @@ instance Default PublishCfg where data PublishCfgRepo = PublishCfgRepo { publishCfgRepoLocation :: !URI - , publishCfgRepoUser :: !String - , publishCfgRepoPass :: !String + , publishCfgRepoUser :: !String + , publishCfgRepoPass :: !String } deriving (Show, Generic) instance FromDhall PublishCfgRepo instance ToDhall PublishCfgRepo + instance FromDhall URI where autoWith norm = fromMaybe (panic "Invalid URI for publish target") . parseURI <$> autoWith norm + instance ToDhall URI where injectWith norm = contramap (show @_ @String) (injectWith norm) + instance IsString URI where fromString = fromMaybe (panic "Invalid URI for publish target") . parseURI -data Shell = Bash | Fish | Zsh deriving Show + +data Shell = Bash | Fish | Zsh deriving (Show) data Command = CmdInit !(Maybe Shell) | CmdRegAdd !String !PublishCfgRepo @@ -238,72 +260,89 @@ data Command | CmdCatDel !String !String | CmdPkgCatAdd !String !PkgId !String | CmdPkgCatDel !String !PkgId !String - deriving Show + deriving (Show) + cfgLocation :: IO FilePath cfgLocation = getHomeDirectory <&> \d -> d ".embassy/publish.dhall" + parseInit :: Parser (Maybe Shell) parseInit = subparser $ command "init" (info go $ progDesc "Initializes embassy-publish config") <> metavar "init" where shells = [Bash, Fish, Zsh] - go = headMay . fmap fst . filter snd . zip shells <$> for shells (switch . long . toS . toLower . show) + go = headMay . fmap fst . filter snd . zip shells <$> for shells (switch . long . toS . toLower . show) + parsePublish :: Parser Upload -parsePublish = subparser $ command "upload" (info go $ progDesc "Publishes a .s9pk to a remote registry") <> metavar - "upload" +parsePublish = + subparser $ + command "upload" (info go $ progDesc "Publishes a .s9pk to a remote registry") + <> metavar + "upload" where - go = liftA3 - Upload - (strOption (short 't' <> long "target" <> metavar "NAME" <> help "Name of registry in publish.dhall")) - (optional $ strOption - (short 'p' <> long "package" <> metavar "S9PK" <> help "File path of the package to publish") - ) - (switch (short 'i' <> long "index" <> help "Index the package after uploading")) + go = + liftA3 + Upload + (strOption (short 't' <> long "target" <> metavar "NAME" <> help "Name of registry in publish.dhall")) + ( optional $ + strOption + (short 'p' <> long "package" <> metavar "S9PK" <> help "File path of the package to publish") + ) + (switch (short 'i' <> long "index" <> help "Index the package after uploading")) + parseRepoAdd :: Parser Command parseRepoAdd = subparser $ command "add" (info go $ progDesc "Add a registry to your config") <> metavar "add" where go :: Parser Command go = - let - publishCfgRepoLocation = + let publishCfgRepoLocation = strOption (short 'l' <> long "location" <> metavar "REGISTRY_URL" <> help "Registry URL") - publishCfgRepoUser = strOption - (short 'u' <> long "username" <> metavar "USERNAME" <> help "Admin username for this registry") - publishCfgRepoPass = strOption - (short 'p' <> long "password" <> metavar "PASSWORD" <> help "Admin password for this registry") + publishCfgRepoUser = + strOption + (short 'u' <> long "username" <> metavar "USERNAME" <> help "Admin username for this registry") + publishCfgRepoPass = + strOption + (short 'p' <> long "password" <> metavar "PASSWORD" <> help "Admin password for this registry") name = strOption - (short 'n' <> long "name" <> metavar "REGISTRY_NAME" <> help - "Name to reference this registry in the future" + ( short 'n' <> long "name" <> metavar "REGISTRY_NAME" + <> help + "Name to reference this registry in the future" ) r = PublishCfgRepo <$> publishCfgRepoLocation <*> publishCfgRepoUser <*> publishCfgRepoPass - in - liftA2 CmdRegAdd name r + in liftA2 CmdRegAdd name r + parseRepoDel :: Parser String parseRepoDel = subparser $ command "rm" (info go $ progDesc "Remove a registry from your config") <> metavar "rm" where - go = strOption - (short 'n' <> long "name" <> metavar "REGISTRY_NAME" <> help - "Registry name chosen when this was originally configured" - ) + go = + strOption + ( short 'n' <> long "name" <> metavar "REGISTRY_NAME" + <> help + "Registry name chosen when this was originally configured" + ) + parseRepoList :: Parser () parseRepoList = subparser $ command "ls" (info (pure ()) $ progDesc "List registries in your config") <> metavar "ls" + parseIndex :: Parser Command parseIndex = - subparser - $ command "index" (info (parseIndexHelper True) $ progDesc "Indexes an existing package version") - <> metavar "index" + subparser $ + command "index" (info (parseIndexHelper True) $ progDesc "Indexes an existing package version") + <> metavar "index" + parseDeindex :: Parser Command parseDeindex = - subparser - $ command "deindex" (info (parseIndexHelper False) $ progDesc "Deindexes an existing package version") - <> metavar "deindex" + subparser $ + command "deindex" (info (parseIndexHelper False) $ progDesc "Deindexes an existing package version") + <> metavar "deindex" + parseIndexHelper :: Bool -> Parser Command parseIndexHelper b = @@ -313,12 +352,16 @@ parseIndexHelper b = <*> strArgument (metavar "VERSION") <*> pure b + parseListUnindexed :: Parser String -parseListUnindexed = subparser $ command - "list-unindexed" - ( info (strOption (short 't' <> long "target" <> metavar "REGISTRY_NAME")) - $ progDesc "Lists unindexed package versions on target registry" - ) +parseListUnindexed = + subparser $ + command + "list-unindexed" + ( info (strOption (short 't' <> long "target" <> metavar "REGISTRY_NAME")) $ + progDesc "Lists unindexed package versions on target registry" + ) + parseCommand :: Parser Command parseCommand = @@ -330,31 +373,39 @@ parseCommand = <|> (CmdListUnindexed <$> parseListUnindexed) <|> parseCat <|> parsePkgCat - where reg = parseRepoAdd <|> (CmdRegDel <$> parseRepoDel) <|> (parseRepoList $> CmdRegList) + where + reg = parseRepoAdd <|> (CmdRegDel <$> parseRepoDel) <|> (parseRepoList $> CmdRegList) + parseCat :: Parser Command parseCat = subparser $ command "category" (info (add <|> del) $ progDesc "Manage categories") where - add = subparser $ command - "add" - ( info - ( CmdCatAdd - <$> strOption (short 't' <> long "target" <> metavar "REGISTRY_NAME") - <*> strArgument (metavar "CATEGORY") - <*> optional (strOption (short 'd' <> long "description" <> metavar "DESCRIPTION")) - <*> optional - (option Options.Applicative.auto (short 'p' <> long "priority" <> metavar "PRIORITY")) + add = + subparser $ + command + "add" + ( info + ( CmdCatAdd + <$> strOption (short 't' <> long "target" <> metavar "REGISTRY_NAME") + <*> strArgument (metavar "CATEGORY") + <*> optional (strOption (short 'd' <> long "description" <> metavar "DESCRIPTION")) + <*> optional + (option Options.Applicative.auto (short 'p' <> long "priority" <> metavar "PRIORITY")) + ) + $ progDesc "Adds category to registry" ) - $ progDesc "Adds category to registry" - ) - del = subparser $ command - "rm" - ( info - (CmdCatDel <$> strOption (short 't' <> long "target" <> metavar "REGISTRY_NAME") <*> strArgument - (metavar "CATEGORY") + del = + subparser $ + command + "rm" + ( info + ( CmdCatDel <$> strOption (short 't' <> long "target" <> metavar "REGISTRY_NAME") + <*> strArgument + (metavar "CATEGORY") + ) + $ progDesc "Removes category from registry" ) - $ progDesc "Removes category from registry" - ) + parsePkgCat :: Parser Command parsePkgCat = subparser $ command "categorize" (info cat $ progDesc "Add or remove package from category") @@ -362,28 +413,32 @@ parsePkgCat = subparser $ command "categorize" (info cat $ progDesc "Add or remo cat :: Parser Command cat = let cmd rm = if not rm then CmdPkgCatAdd else CmdPkgCatDel - in cmd + in cmd <$> switch (long "remove") <*> strOption (short 't' <> long "target" <> metavar "REGISTRY_NAME") <*> strArgument (metavar "PACKAGE_ID") <*> strArgument (metavar "CATEGORY") + opts :: ParserInfo Command opts = info (parseCommand <**> helper) (fullDesc <> progDesc "Publish tool for Embassy Packages") + cliMain :: IO () -cliMain = execParser opts >>= \case - CmdInit sh -> init sh - CmdRegAdd s pcr -> regAdd s pcr - CmdRegDel s -> regRm s - CmdRegList -> regLs - CmdUpload up -> upload up - CmdIndex name pkg v shouldIndex -> if shouldIndex then index name pkg v else deindex name pkg v - CmdListUnindexed name -> listUnindexed name - CmdCatAdd target cat desc pri -> catAdd target cat desc pri - CmdCatDel target cat -> catDel target cat - CmdPkgCatAdd target pkg cat -> pkgCatAdd target pkg cat - CmdPkgCatDel target pkg cat -> pkgCatDel target pkg cat +cliMain = + execParser opts >>= \case + CmdInit sh -> init sh + CmdRegAdd s pcr -> regAdd s pcr + CmdRegDel s -> regRm s + CmdRegList -> regLs + CmdUpload up -> upload up + CmdIndex name pkg v shouldIndex -> if shouldIndex then index name pkg v else deindex name pkg v + CmdListUnindexed name -> listUnindexed name + CmdCatAdd target cat desc pri -> catAdd target cat desc pri + CmdCatDel target cat -> catDel target cat + CmdPkgCatAdd target pkg cat -> pkgCatAdd target pkg cat + CmdPkgCatDel target pkg cat -> pkgCatDel target pkg cat + init :: Maybe Shell -> IO () init sh = do @@ -405,10 +460,9 @@ init sh = do writeFile zshcompleter (toS res) - regAdd :: String -> PublishCfgRepo -> IO () regAdd name val = do - loc <- cfgLocation + loc <- cfgLocation PublishCfg cfg <- inputFile Dhall.auto loc let cfg' = insert name val cfg writeFile loc (pretty $ embed inject $ PublishCfg cfg') @@ -423,16 +477,18 @@ regAdd name val = do . mappend "start9_admin:" $ publishCfgRepoPass val + regRm :: String -> IO () regRm name = do - loc <- cfgLocation + loc <- cfgLocation PublishCfg cfg <- inputFile Dhall.auto loc let cfg' = delete name cfg writeFile loc (pretty $ embed inject $ PublishCfg cfg') + regLs :: IO () regLs = do - loc <- cfgLocation + loc <- cfgLocation PublishCfg cfg <- inputFile Dhall.auto loc void $ traverseWithKey f cfg where @@ -440,19 +496,20 @@ regLs = do putChunk $ fromString (k <> ": ") & fore yellow putChunkLn $ fromString (show $ publishCfgRepoLocation v) & fore magenta + upload :: Upload -> IO () upload (Upload name mpkg shouldIndex) = do - PublishCfgRepo {..} <- findNameInCfg name - pkg <- case mpkg of + PublishCfgRepo{..} <- findNameInCfg name + pkg <- case mpkg of Nothing -> do - cwd <- getCurrentDirectory + cwd <- getCurrentDirectory files <- listDirectory cwd let pkgs = filter (\n -> takeExtension n == ".s9pk") files case pkgs of [] -> do $logError "No package specified, and could not find one in this directory" exitWith $ ExitFailure 1 - [p ] -> pure (cwd p) + [p] -> pure (cwd p) (_ : _ : _) -> do $logWarn "Ambiguous package upload request, found multiple candidates:" for_ pkgs $ \f -> $logWarn (fromString f) @@ -460,25 +517,25 @@ upload (Upload name mpkg shouldIndex) = do Just s -> pure s noBody <- parseRequest ("POST " <> show publishCfgRepoLocation <> "/admin/v0/upload") - <&> setRequestHeaders [("accept", "text/plain")] - <&> applyBasicAuth (B8.pack publishCfgRepoUser) (B8.pack publishCfgRepoPass) + <&> setRequestHeaders [("accept", "text/plain")] + <&> applyBasicAuth (B8.pack publishCfgRepoUser) (B8.pack publishCfgRepoPass) size <- getFileSize pkg - bar <- newProgressBar defStyle 30 (Progress 0 (fromIntegral size) ()) + bar <- newProgressBar defStyle 30 (Progress 0 (fromIntegral size) ()) body <- observedStreamFile (updateProgress bar . const . sfs2prog) pkg let withBody = setRequestBody body noBody manager <- newTlsManager - res <- runReaderT (httpLbs withBody) manager + res <- runReaderT (httpLbs withBody) manager if getResponseStatus res == status200 - -- no output is successful - then pure () + then -- no output is successful + pure () else do $logError (decodeUtf8 . LB.toStrict $ getResponseBody res) exitWith $ ExitFailure 1 putChunkLn $ fromString ("Successfully uploaded " <> pkg) & fore green when shouldIndex $ do - home <- getHomeDirectory + home <- getHomeDirectory manifestBytes <- sourceManifest (home ".cargo/bin") pkg $ \c -> runConduit (c .| foldC) - PackageManifest { packageManifestId, packageManifestVersion } <- case eitherDecodeStrict manifestBytes of + PackageManifest{packageManifestId, packageManifestVersion} <- case eitherDecodeStrict manifestBytes of Left s -> do $logError $ "Could not parse the manifest of the package: " <> toS s exitWith $ ExitFailure 1 @@ -486,45 +543,53 @@ upload (Upload name mpkg shouldIndex) = do let pkgId = toS $ unPkgId packageManifestId index name pkgId packageManifestVersion putChunkLn $ fromString ("Successfully indexed " <> pkgId <> "@" <> show packageManifestVersion) & fore green - where sfs2prog :: StreamFileStatus -> Progress () - sfs2prog StreamFileStatus {..} = Progress (fromIntegral readSoFar) (fromIntegral fileSize) () + sfs2prog StreamFileStatus{..} = Progress (fromIntegral readSoFar) (fromIntegral fileSize) () + index :: String -> String -> Version -> IO () index name pkg v = performHttp name "POST" [i|/admin/v0/index|] (IndexPkgReq (PkgId $ toS pkg) v) + deindex :: String -> String -> Version -> IO () deindex name pkg v = performHttp name "POST" [i|/admin/v0/deindex|] (IndexPkgReq (PkgId $ toS pkg) v) + listUnindexed :: String -> IO () listUnindexed name = do - PublishCfgRepo {..} <- findNameInCfg name - noBody <- + PublishCfgRepo{..} <- findNameInCfg name + noBody <- parseRequest (show publishCfgRepoLocation <> "/admin/v0/deindex") - <&> setRequestHeaders [("accept", "application/json")] - <&> applyBasicAuth (B8.pack publishCfgRepoUser) (B8.pack publishCfgRepoPass) - PackageList {..} <- getResponseBody <$> httpJSON noBody - void $ flip traverseWithKey unPackageList $ \k v -> do - putChunk (chunk (unPkgId k <> ": ") & fore blue) - putChunkLn $ chunk (show v) & fore yellow + <&> setRequestHeaders [("accept", "application/json")] + <&> applyBasicAuth (B8.pack publishCfgRepoUser) (B8.pack publishCfgRepoPass) + PackageList{..} <- getResponseBody <$> httpJSON noBody + void $ + flip traverseWithKey unPackageList $ \k v -> do + putChunk (chunk (unPkgId k <> ": ") & fore blue) + putChunkLn $ chunk (show v) & fore yellow + catAdd :: String -> String -> Maybe String -> Maybe Int -> IO () catAdd target name desc pri = performHttp target "POST" [i|/admin/v0/category/#{name}|] (AddCategoryReq (toS <$> desc) pri) + catDel :: String -> String -> IO () catDel target name = performHttp target "DELETE" [i|/admin/v0/category/#{name}|] () + pkgCatAdd :: String -> PkgId -> String -> IO () pkgCatAdd target pkg cat = performHttp target "POST" [i|/admin/v0/categorize/#{cat}/#{pkg}|] () + pkgCatDel :: String -> PkgId -> String -> IO () pkgCatDel target pkg cat = performHttp target "DELETE" [i|/admin/v0/categorize/#{cat}/#{pkg}|] () + findNameInCfg :: String -> IO PublishCfgRepo findNameInCfg name = do - loc <- cfgLocation + loc <- cfgLocation PublishCfg cfg <- inputFile Dhall.auto loc case lookup name cfg of Nothing -> do @@ -532,13 +597,14 @@ findNameInCfg name = do exitWith $ ExitFailure 1 Just pcr -> pure pcr + performHttp :: ToJSON a => String -> String -> String -> a -> IO () performHttp target method route body = do - PublishCfgRepo {..} <- findNameInCfg target - noBody <- + PublishCfgRepo{..} <- findNameInCfg target + noBody <- parseRequest (method <> " " <> show publishCfgRepoLocation <> route) - <&> setRequestHeaders [("accept", "text/plain")] - <&> applyBasicAuth (B8.pack publishCfgRepoUser) (B8.pack publishCfgRepoPass) + <&> setRequestHeaders [("accept", "text/plain")] + <&> applyBasicAuth (B8.pack publishCfgRepoUser) (B8.pack publishCfgRepoPass) let withBody = setRequestBodyJSON body noBody res <- httpLBS withBody if getResponseStatus res == status200 @@ -549,12 +615,13 @@ performHttp target method route body = do instance MonadLogger IO where - monadLoggerLog _ _ LevelDebug = putChunkLn . colorLog white - monadLoggerLog _ _ LevelInfo = putChunkLn . colorLog blue - monadLoggerLog _ _ LevelWarn = putChunkLn . colorLog yellow - monadLoggerLog _ _ LevelError = putChunkLn . colorLog red + monadLoggerLog _ _ LevelDebug = putChunkLn . colorLog white + monadLoggerLog _ _ LevelInfo = putChunkLn . colorLog blue + monadLoggerLog _ _ LevelWarn = putChunkLn . colorLog yellow + monadLoggerLog _ _ LevelError = putChunkLn . colorLog red monadLoggerLog _ _ (LevelOther _) = putChunkLn . colorLog magenta + colorLog :: ToLogStr msg => Radiant -> msg -> Chunk colorLog c m = fore c $ chunk . decodeUtf8 . fromLogStr . toLogStr $ m instance MonadLoggerIO IO where diff --git a/src/Database/Marketplace.hs b/src/Database/Marketplace.hs deleted file mode 100644 index 6a4320c..0000000 --- a/src/Database/Marketplace.hs +++ /dev/null @@ -1,225 +0,0 @@ -{-# 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 - ) - -type CategoryTitle = Text - -searchServices :: (MonadResource m, MonadIO m) - => Maybe CategoryTitle - -> 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 ++. (%)) - ) - groupBy (service ^. VersionRecordPkgId, service ^. VersionRecordNumber) - orderBy - [ asc (service ^. VersionRecordPkgId) - , desc (service ^. VersionRecordNumber) - , desc (service ^. VersionRecordUpdatedAt) - ] - 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 - ) - groupBy (services ^. VersionRecordPkgId, services ^. VersionRecordNumber) - orderBy - [ asc (services ^. VersionRecordPkgId) - , desc (services ^. VersionRecordNumber) - , desc (services ^. VersionRecordUpdatedAt) - ] - 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 pkgId pkgVersion = select $ do - from - (do - (pkgDepRecord :& depPkgRecord) <- - 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 = 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) - -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 - mvn <- await - case mvn of - Nothing -> pure Nothing - Just vn -> 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) - -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 - } - -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) - where_ (service ^. PkgRecordId ==. val (PkgRecordKey appId)) - pure (service, version) - where sortResults = fmap $ sortOn (Down . versionRecordNumber . entityVal . snd) diff --git a/src/Database/Queries.hs b/src/Database/Queries.hs index 0777ee4..ffe9390 100644 --- a/src/Database/Queries.hs +++ b/src/Database/Queries.hs @@ -1,65 +1,280 @@ -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeApplications #-} module Database.Queries where -import Database.Persist.Sql ( PersistStoreRead(get) - , PersistStoreWrite(insertKey, insert_, repsert) - , SqlBackend - ) -import Lib.Types.AppIndex ( PackageManifest(..) - , PkgId - ) -import Lib.Types.Emver ( Version ) -import Model ( Key(PkgRecordKey, VersionRecordKey) - , Metric(Metric) - , PkgRecord(PkgRecord) - , VersionRecord(VersionRecord) - ) -import Orphans.Emver ( ) -import Startlude ( ($) - , (.) - , ConvertText(toS) - , Maybe(..) - , MonadIO(..) - , ReaderT - , SomeException - , getCurrentTime - , maybe - ) -import System.FilePath ( takeExtension ) -import UnliftIO ( MonadUnliftIO - , try - ) +import Database.Persist.Sql ( + PersistStoreRead (get), + PersistStoreWrite (insertKey, insert_, repsert), + SqlBackend, + ) +import Lib.Types.Core ( + PkgId, + ) +import Lib.Types.Emver (Version) +import Model ( + Key (PkgRecordKey, VersionRecordKey), + Metric (Metric), + PkgDependency (..), + PkgRecord (PkgRecord), + VersionRecord (VersionRecord), + ) +import Orphans.Emver () +import Startlude ( + ConvertText (toS), + Maybe (..), + MonadIO (..), + ReaderT, + SomeException, + getCurrentTime, + maybe, + ($), + (.), + ) +import System.FilePath (takeExtension) +import UnliftIO ( + MonadUnliftIO, + try, + ) + +import Conduit ( + ConduitT, + MonadResource, + awaitForever, + leftover, + yield, + ) +import Control.Monad.Loops (unfoldM) +import Data.Conduit (await) +import Database.Esqueleto.Experimental ( + PersistEntity, + SqlExpr, + Value, + 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 (entityVal), + runSqlPool, + ) +import Lib.Types.Manifest (PackageManifest (..)) +import Model ( + Category, + EntityField ( + CategoryId, + CategoryName, + PkgCategoryCategoryId, + PkgCategoryPkgId, + PkgDependencyPkgId, + PkgDependencyPkgVersion, + PkgRecordId, + VersionRecordDescLong, + VersionRecordDescShort, + VersionRecordNumber, + VersionRecordPkgId, + VersionRecordTitle, + VersionRecordUpdatedAt + ), + Key (unPkgRecordKey), + PkgCategory, + VersionRecord (versionRecordNumber, versionRecordPkgId), + ) +import Startlude ( + Applicative (pure), + Bool, + Down (Down), + Eq ((==)), + Functor (fmap), + Monad, + Text, + headMay, + snd, + sortOn, + ($>), + (<$>), + ) + + +serviceQuerySource :: + (MonadResource m, MonadIO m) => + Maybe Text -> + Text -> + ConduitT () (Entity VersionRecord) (ReaderT SqlBackend m) () +serviceQuerySource mCat query = selectSource $ do + service <- case mCat of + Nothing -> do + service <- from $ table @VersionRecord + where_ $ queryInMetadata query service + pure service + Just category -> do + (service :& _ :& cat) <- + from $ + table @VersionRecord + `innerJoin` table @PkgCategory `on` (VersionRecordPkgId === PkgCategoryPkgId) + `innerJoin` table @Category `on` (\(_ :& a :& b) -> (PkgCategoryCategoryId === CategoryId) (a :& b)) + -- if there is a cateogry, only search in category + -- weight title, short, long (bitcoin should equal Bitcoin Core) + where_ $ cat ^. CategoryName ==. val category &&. queryInMetadata query service + pure service + groupBy (service ^. VersionRecordPkgId, service ^. VersionRecordNumber) + orderBy + [ asc (service ^. VersionRecordPkgId) + , desc (service ^. VersionRecordNumber) + , desc (service ^. VersionRecordUpdatedAt) + ] + pure service + + +queryInMetadata :: Text -> SqlExpr (Entity VersionRecord) -> (SqlExpr (Value Bool)) +queryInMetadata query service = + (service ^. VersionRecordDescShort `ilike` (%) ++. val query ++. (%)) + ||. (service ^. VersionRecordDescLong `ilike` (%) ++. val query ++. (%)) + ||. (service ^. VersionRecordTitle `ilike` (%) ++. val query ++. (%)) + + +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 + + +getPkgDependencyData :: + MonadIO m => + PkgId -> + Version -> + ReaderT SqlBackend m [PkgDependency] +getPkgDependencyData pkgId pkgVersion = fmap (fmap entityVal) $ + select $ + from $ do + pkgDepRecord <- from $ table @PkgDependency + where_ (pkgDepRecord ^. PkgDependencyPkgId ==. val (PkgRecordKey pkgId)) + where_ (pkgDepRecord ^. PkgDependencyPkgVersion ==. val pkgVersion) + pure pkgDepRecord + + +(===) :: + (PersistEntity val1, PersistEntity val2, P.PersistField typ) => + EntityField val1 typ -> + EntityField val2 typ -> + (SqlExpr (Entity val1) :& SqlExpr (Entity val2)) -> + SqlExpr (Value Bool) +(===) a' b' (a :& b) = a ^. a' ==. b ^. b' + + +getCategoriesFor :: + MonadUnliftIO m => + PkgId -> + ReaderT SqlBackend m [Category] +getCategoriesFor pkg = fmap (fmap entityVal) $ + select $ do + (sc :& cat) <- + from $ + table @PkgCategory + `innerJoin` table @Category `on` (PkgCategoryCategoryId === CategoryId) + where_ (sc ^. PkgCategoryPkgId ==. val (PkgRecordKey pkg)) + pure cat + + +collateVersions :: + MonadUnliftIO m => + ConduitT (Entity VersionRecord) (PkgId, [VersionRecord]) (ReaderT SqlBackend m) () +collateVersions = awaitForever $ \v0 -> do + let pkg = unPkgRecordKey . versionRecordPkgId $ entityVal v0 + let pull = do + mvn <- await + case mvn of + Nothing -> pure Nothing + Just vn -> do + let pkg' = unPkgRecordKey . versionRecordPkgId $ entityVal vn + if pkg == pkg' then pure (Just vn) else leftover vn $> Nothing + ls <- unfoldM pull + yield (pkg, fmap entityVal $ v0 : ls) + + +getDependencyVersions :: + (Monad m, MonadIO m) => + PkgDependency -> + ReaderT SqlBackend m [VersionRecord] +getDependencyVersions pkgDepRecord = do + let pkgDbId = pkgDependencyDepId pkgDepRecord + depVers <- select $ do + v <- from $ table @VersionRecord + where_ $ v ^. VersionRecordPkgId ==. val pkgDbId + pure v + pure $ entityVal <$> depVers + + +fetchAllAppVersions :: MonadUnliftIO m => ConnectionPool -> PkgId -> m [VersionRecord] +fetchAllAppVersions appConnPool appId = do + entityAppVersions <- runSqlPool (P.selectList [VersionRecordPkgId P.==. PkgRecordKey appId] []) appConnPool + pure $ entityVal <$> entityAppVersions -fetchApp :: MonadIO m => PkgId -> ReaderT SqlBackend m (Maybe PkgRecord) -fetchApp = get . PkgRecordKey fetchAppVersion :: MonadIO m => PkgId -> Version -> ReaderT SqlBackend m (Maybe VersionRecord) fetchAppVersion pkgId version = get (VersionRecordKey (PkgRecordKey pkgId) version) + +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) + where_ (service ^. PkgRecordId ==. val (PkgRecordKey appId)) + pure (service, version) + where + sortResults = fmap $ sortOn (Down . versionRecordNumber . entityVal . snd) + + createMetric :: MonadIO m => PkgId -> Version -> ReaderT SqlBackend m () createMetric appId version = do time <- liftIO getCurrentTime insert_ $ Metric time (PkgRecordKey appId) version + upsertPackageVersion :: (MonadUnliftIO m) => PackageManifest -> ReaderT SqlBackend m () -upsertPackageVersion PackageManifest {..} = do +upsertPackageVersion PackageManifest{..} = do now <- liftIO getCurrentTime let iconType = maybe "png" (toS . takeExtension . toS) packageManifestIcon - let pkgId = PkgRecordKey packageManifestId - let ins = VersionRecord now - (Just now) - pkgId - packageManifestVersion - packageManifestTitle - packageManifestDescriptionShort - packageManifestDescriptionLong - iconType - packageManifestReleaseNotes - packageManifestEosVersion - Nothing + let pkgId = PkgRecordKey packageManifestId + let ins = + VersionRecord + now + (Just now) + pkgId + packageManifestVersion + packageManifestTitle + packageManifestDescriptionShort + packageManifestDescriptionLong + iconType + packageManifestReleaseNotes + packageManifestEosVersion + Nothing _res <- try @_ @SomeException $ insertKey pkgId (PkgRecord now (Just now)) repsert (VersionRecordKey pkgId packageManifestVersion) ins diff --git a/src/Foundation.hs b/src/Foundation.hs index a01ed67..b84c739 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1,184 +1,202 @@ -{-# 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 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.Core (PkgId, S9PK) +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 +211,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 +285,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 +297,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..7d60d15 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -1,128 +1,148 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} + module Handler.Admin where -import Conduit ( (.|) - , runConduit - , sinkFile - ) -import Control.Exception ( ErrorCall(ErrorCall) ) -import Control.Monad.Reader.Has ( ask ) -import Control.Monad.Trans.Maybe ( MaybeT(..) ) -import Data.Aeson ( (.:) - , (.:?) - , (.=) - , FromJSON(parseJSON) - , ToJSON - , decodeFileStrict - , object - , withObject - ) -import Data.HashMap.Internal.Strict ( HashMap - , differenceWith - , filter - , fromListWith - ) -import Data.List ( (\\) - , null - ) -import Data.String.Interpolate.IsString - ( i ) -import Database.Persist ( Entity(entityKey) - , PersistStoreRead(get) - , PersistUniqueRead(getBy) - , PersistUniqueWrite(deleteBy, insertUnique, upsert) - , entityVal - , insert_ - , selectList - ) -import Database.Persist.Postgresql ( runSqlPoolNoTransaction ) -import Database.Queries ( upsertPackageVersion ) -import Foundation ( Handler - , RegistryCtx(..) - ) -import Lib.PkgRepository ( PkgRepo(PkgRepo, pkgRepoFileRoot) - , extractPkg - , getManifestLocation - , getPackages - , getVersionsFor - ) -import Lib.Types.AppIndex ( PackageManifest(..) - , PkgId(unPkgId) - ) -import Lib.Types.Emver ( Version(..) ) -import Model ( Category(..) - , Key(AdminKey, PkgRecordKey, VersionRecordKey) - , PkgCategory(PkgCategory) - , Unique(UniqueName, UniquePkgCategory) - , Upload(..) - , VersionRecord(versionRecordNumber, versionRecordPkgId) - , unPkgRecordKey - ) -import Network.HTTP.Types ( status403 - , status404 - , status500 - ) -import Settings -import Startlude ( ($) - , (&&&) - , (.) - , (<$>) - , (<<$>>) - , (<>) - , Applicative(pure) - , Bool(..) - , Eq - , Int - , Maybe(..) - , Monad((>>=)) - , Show - , SomeException(..) - , Text - , asum - , fmap - , fromMaybe - , getCurrentTime - , guarded - , hush - , isNothing - , liftIO - , not - , replicate - , show - , throwIO - , toS - , traverse - , void - , when - , zip - ) -import System.FilePath ( (<.>) - , () - ) -import UnliftIO ( try - , withTempDirectory - ) -import UnliftIO.Directory ( createDirectoryIfMissing - , removePathForcibly - , renameDirectory - , renameFile - ) -import Util.Shared ( orThrow - , sendResponseText - ) -import Yesod ( ToJSON(..) - , delete - , getsYesod - , logError - , rawRequestBody - , requireCheckJsonBody - , runDB - ) -import Yesod.Auth ( YesodAuth(maybeAuthId) ) -import Yesod.Core.Types ( JSONResponse(JSONResponse) ) +import Conduit ( + runConduit, + sinkFile, + (.|), + ) +import Control.Exception (ErrorCall (ErrorCall)) +import Control.Monad.Reader.Has (ask) +import Control.Monad.Trans.Maybe (MaybeT (..)) +import Data.Aeson ( + FromJSON (parseJSON), + ToJSON, + decodeFileStrict, + object, + withObject, + (.:), + (.:?), + (.=), + ) +import Data.HashMap.Internal.Strict ( + HashMap, + differenceWith, + filter, + fromListWith, + ) +import Data.List ( + null, + (\\), + ) +import Data.String.Interpolate.IsString ( + i, + ) +import Database.Persist ( + Entity (entityKey), + PersistStoreRead (get), + PersistUniqueRead (getBy), + PersistUniqueWrite (deleteBy, insertUnique, upsert), + entityVal, + insert_, + selectList, + ) +import Database.Persist.Postgresql (runSqlPoolNoTransaction) +import Database.Queries (upsertPackageVersion) +import Foundation ( + Handler, + RegistryCtx (..), + ) +import Handler.Util ( + orThrow, + sendResponseText, + ) +import Lib.PkgRepository ( + PkgRepo (PkgRepo, pkgRepoFileRoot), + extractPkg, + getManifestLocation, + getPackages, + getVersionsFor, + ) +import Lib.Types.Core ( + PkgId (unPkgId), + ) +import Lib.Types.Emver (Version (..)) +import Lib.Types.Manifest (PackageManifest (..)) +import Model ( + Category (..), + Key (AdminKey, PkgRecordKey, VersionRecordKey), + PkgCategory (PkgCategory), + Unique (UniqueName, UniquePkgCategory), + Upload (..), + VersionRecord (versionRecordNumber, versionRecordPkgId), + unPkgRecordKey, + ) +import Network.HTTP.Types ( + status403, + status404, + status500, + ) +import Settings +import Startlude ( + Applicative (pure), + Bool (..), + Eq, + Int, + Maybe (..), + Monad ((>>=)), + Show, + SomeException (..), + Text, + asum, + fmap, + fromMaybe, + getCurrentTime, + guarded, + hush, + isNothing, + liftIO, + not, + replicate, + show, + throwIO, + toS, + traverse, + void, + when, + zip, + ($), + (&&&), + (.), + (.*), + (<$>), + (<<$>>), + (<>), + ) +import System.FilePath ( + (<.>), + (), + ) +import UnliftIO ( + try, + withTempDirectory, + ) +import UnliftIO.Directory ( + createDirectoryIfMissing, + removePathForcibly, + renameDirectory, + renameFile, + ) +import Yesod ( + ToJSON (..), + delete, + getsYesod, + logError, + rawRequestBody, + requireCheckJsonBody, + runDB, + ) +import Yesod.Auth (YesodAuth (maybeAuthId)) +import Yesod.Core.Types (JSONResponse (JSONResponse)) + postPkgUploadR :: Handler () postPkgUploadR = do @@ -131,14 +151,15 @@ postPkgUploadR = do withTempDirectory resourcesTemp "newpkg" $ \dir -> do let path = dir "temp" <.> "s9pk" runConduit $ rawRequestBody .| sinkFile path - pool <- getsYesod appConnPool - PkgRepo {..} <- ask - res <- retry $ extractPkg pool path + pool <- getsYesod appConnPool + PkgRepo{..} <- ask + res <- retry $ extractPkg pool path when (isNothing res) $ do $logError "Failed to extract package" sendResponseText status500 "Failed to extract package" - PackageManifest {..} <- liftIO (decodeFileStrict (dir "manifest.json")) - `orThrow` sendResponseText status500 "Failed to parse manifest.json" + PackageManifest{..} <- + liftIO (decodeFileStrict (dir "manifest.json")) + `orThrow` sendResponseText status500 "Failed to parse manifest.json" renameFile path (dir (toS . unPkgId) packageManifestId <.> "s9pk") let targetPath = pkgRepoFileRoot show packageManifestId show packageManifestVersion removePathForcibly targetPath @@ -153,92 +174,100 @@ postPkgUploadR = do Just name -> do now <- liftIO getCurrentTime runDB $ insert_ (Upload (AdminKey name) (PkgRecordKey packageManifestId) packageManifestVersion now) - where retry m = runMaybeT . asum $ replicate 3 (MaybeT $ hush <$> try @_ @SomeException m) + where + retry m = runMaybeT . asum $ replicate 3 (MaybeT $ hush <$> try @_ @SomeException m) data IndexPkgReq = IndexPkgReq - { indexPkgReqId :: !PkgId + { indexPkgReqId :: !PkgId , indexPkgReqVersion :: !Version } deriving (Eq, Show) instance FromJSON IndexPkgReq where parseJSON = withObject "Index Package Request" $ \o -> do - indexPkgReqId <- o .: "id" + indexPkgReqId <- o .: "id" indexPkgReqVersion <- o .: "version" - pure IndexPkgReq { .. } + pure IndexPkgReq{..} instance ToJSON IndexPkgReq where - toJSON IndexPkgReq {..} = object ["id" .= indexPkgReqId, "version" .= indexPkgReqVersion] + toJSON IndexPkgReq{..} = object ["id" .= indexPkgReqId, "version" .= indexPkgReqVersion] + postPkgIndexR :: Handler () postPkgIndexR = do - IndexPkgReq {..} <- requireCheckJsonBody - manifest <- getManifestLocation indexPkgReqId indexPkgReqVersion - man <- liftIO (decodeFileStrict manifest) `orThrow` sendResponseText - status404 - [i|Could not locate manifest for #{indexPkgReqId}@#{indexPkgReqVersion}|] + IndexPkgReq{..} <- requireCheckJsonBody + manifest <- getManifestLocation indexPkgReqId indexPkgReqVersion + man <- + liftIO (decodeFileStrict manifest) + `orThrow` sendResponseText + status404 + [i|Could not locate manifest for #{indexPkgReqId}@#{indexPkgReqVersion}|] pool <- getsYesod appConnPool runSqlPoolNoTransaction (upsertPackageVersion man) pool Nothing + postPkgDeindexR :: Handler () postPkgDeindexR = do - IndexPkgReq {..} <- requireCheckJsonBody + IndexPkgReq{..} <- requireCheckJsonBody runDB $ delete (VersionRecordKey (PkgRecordKey indexPkgReqId) indexPkgReqVersion) -newtype PackageList = PackageList { unPackageList :: HashMap PkgId [Version] } + +newtype PackageList = PackageList {unPackageList :: HashMap PkgId [Version]} instance FromJSON PackageList where parseJSON = fmap PackageList . parseJSON instance ToJSON PackageList where toJSON = toJSON . unPackageList + getPkgDeindexR :: Handler (JSONResponse PackageList) getPkgDeindexR = do dbList <- - runDB - $ (unPkgRecordKey . versionRecordPkgId &&& (: []) . versionRecordNumber) - . entityVal - <<$>> selectList [] [] + runDB $ + (unPkgRecordKey . versionRecordPkgId &&& (: []) . versionRecordNumber) + . entityVal + <<$>> selectList [] [] let inDb = fromListWith (<>) dbList pkgsOnDisk <- getPackages - onDisk <- fromListWith (<>) . zip pkgsOnDisk <$> traverse getVersionsFor pkgsOnDisk + onDisk <- fromListWith (<>) . zip pkgsOnDisk <$> traverse getVersionsFor pkgsOnDisk pure . JSONResponse . PackageList $ filter (not . null) $ differenceWith (guarded null .* (\\)) onDisk inDb -{-# INLINE (.*) #-} -infixr 8 .* -(.*) :: (b -> c) -> (a1 -> a2 -> b) -> a1 -> a2 -> c -(.*) = (.) . (.) data AddCategoryReq = AddCategoryReq { addCategoryDescription :: !(Maybe Text) - , addCategoryPriority :: !(Maybe Int) + , addCategoryPriority :: !(Maybe Int) } instance FromJSON AddCategoryReq where parseJSON = withObject "AddCategoryReq" $ \o -> do addCategoryDescription <- o .:? "description" - addCategoryPriority <- o .:? "priority" - pure AddCategoryReq { .. } + addCategoryPriority <- o .:? "priority" + pure AddCategoryReq{..} instance ToJSON AddCategoryReq where - toJSON AddCategoryReq {..} = object ["description" .= addCategoryDescription, "priority" .= addCategoryPriority] + toJSON AddCategoryReq{..} = object ["description" .= addCategoryDescription, "priority" .= addCategoryPriority] + postCategoryR :: Text -> Handler () postCategoryR cat = do - AddCategoryReq {..} <- requireCheckJsonBody - now <- liftIO getCurrentTime + AddCategoryReq{..} <- requireCheckJsonBody + now <- liftIO getCurrentTime void . runDB $ upsert (Category now cat (fromMaybe "" addCategoryDescription) (fromMaybe 0 addCategoryPriority)) [] + deleteCategoryR :: Text -> Handler () deleteCategoryR cat = runDB $ deleteBy (UniqueName cat) + postPkgCategorizeR :: Text -> PkgId -> Handler () postPkgCategorizeR cat pkg = runDB $ do - catEnt <- getBy (UniqueName cat) `orThrow` sendResponseText status404 [i|Category "#{cat}" does not exist|] + catEnt <- getBy (UniqueName cat) `orThrow` sendResponseText status404 [i|Category "#{cat}" does not exist|] _pkgEnt <- get (PkgRecordKey pkg) `orThrow` sendResponseText status404 [i|Package "#{pkg}" does not exist|] - now <- liftIO getCurrentTime - void $ insertUnique (PkgCategory now (PkgRecordKey pkg) (entityKey catEnt)) `orThrow` sendResponseText - status403 - [i|Package "#{pkg}" is already assigned to category "#{cat}"|] + now <- liftIO getCurrentTime + void $ + insertUnique (PkgCategory now (PkgRecordKey pkg) (entityKey catEnt)) + `orThrow` sendResponseText + status403 + [i|Package "#{pkg}" is already assigned to category "#{cat}"|] + deletePkgCategorizeR :: Text -> PkgId -> Handler () deletePkgCategorizeR cat pkg = runDB $ do catEnt <- getBy (UniqueName cat) `orThrow` sendResponseText status404 [i|Category "#{cat}" does not exist|] deleteBy (UniquePkgCategory (PkgRecordKey pkg) (entityKey catEnt)) - diff --git a/src/Handler/Apps.hs b/src/Handler/Apps.hs deleted file mode 100644 index 187da10..0000000 --- a/src/Handler/Apps.hs +++ /dev/null @@ -1,113 +0,0 @@ -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} - -module Handler.Apps where - -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 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 (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 new file mode 100644 index 0000000..dc6fa79 --- /dev/null +++ b/src/Handler/Eos/V0/EosImg.hs @@ -0,0 +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 new file mode 100644 index 0000000..d0054eb --- /dev/null +++ b/src/Handler/Eos/V0/Latest.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE RecordWildCards #-} + +module Handler.Eos.V0.Latest where + +import Data.Aeson (ToJSON (toJSON), object, (.=)) +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 (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 + { 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 + + +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 3369d03..0000000 --- a/src/Handler/Icons.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Handler.Icons where - -import Startlude ( ($) - , Eq - , Generic - , Read - , Show - , show - ) - -import Data.Conduit ( (.|) - , awaitForever - ) -import Data.String.Interpolate.IsString - ( i ) -import Foundation ( Handler ) -import Lib.Error ( S9Error(NotFoundE) ) -import Lib.PkgRepository ( getBestVersion - , getIcon - , getInstructions - , getLicense - ) -import Lib.Types.AppIndex ( PkgId ) -import Network.HTTP.Types ( status400 ) -import Util.Shared ( getVersionSpecFromQuery - , orThrow - , versionPriorityFromQueryIsMin - ) -import Yesod.Core ( FromJSON - , ToJSON - , TypedContent - , addHeader - , respondSource - , sendChunkBS - , sendResponseStatus - , typePlain - ) - -data IconType = PNG | JPG | JPEG | SVG - 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 deleted file mode 100644 index 776ac5e..0000000 --- a/src/Handler/Marketplace.hs +++ /dev/null @@ -1,451 +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 qualified Data.Attoparsec.Text as Atto - -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) - -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 - -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 diff --git a/src/Handler/Package.hs b/src/Handler/Package.hs new file mode 100644 index 0000000..294d48c --- /dev/null +++ b/src/Handler/Package.hs @@ -0,0 +1,59 @@ +module Handler.Package where + +import Foundation (Handler) +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.Core (PkgId, S9PK) +import Yesod.Core.Types ( + JSONResponse, + TypedContent, + ) + + +getInfoR :: ApiVersion -> Handler (JSONResponse InfoRes) +getInfoR _ = Handler.Package.V0.Info.getInfoR + + +getPackageIndexR :: ApiVersion -> Handler PackageListRes +getPackageIndexR _ = Handler.Package.V0.Index.getPackageIndexR + + +getVersionLatestR :: ApiVersion -> Handler VersionLatestRes +getVersionLatestR _ = Handler.Package.V0.Latest.getVersionLatestR + + +getAppR :: ApiVersion -> S9PK -> Handler TypedContent +getAppR _ = Handler.Package.V0.S9PK.getAppR + + +getAppManifestR :: ApiVersion -> PkgId -> Handler TypedContent +getAppManifestR _ = Handler.Package.V0.Manifest.getAppManifestR + + +getReleaseNotesR :: ApiVersion -> PkgId -> Handler ReleaseNotes +getReleaseNotesR _ = Handler.Package.V0.ReleaseNotes.getReleaseNotesR + + +getIconsR :: ApiVersion -> PkgId -> Handler TypedContent +getIconsR _ = Handler.Package.V0.Icon.getIconsR + + +getLicenseR :: ApiVersion -> PkgId -> Handler TypedContent +getLicenseR _ = Handler.Package.V0.License.getLicenseR + + +getInstructionsR :: ApiVersion -> PkgId -> Handler TypedContent +getInstructionsR _ = Handler.Package.V0.Instructions.getInstructionsR + + +getPkgVersionR :: ApiVersion -> PkgId -> Handler AppVersionRes +getPkgVersionR _ = Handler.Package.V0.Version.getPkgVersionR diff --git a/src/Handler/Package/V0/Icon.hs b/src/Handler/Package/V0/Icon.hs new file mode 100644 index 0000000..352a5de --- /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.Core (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..5df0991 --- /dev/null +++ b/src/Handler/Package/V0/Index.hs @@ -0,0 +1,302 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} + +module Handler.Package.V0.Index where + +import Conduit (concatMapC, dropC, mapC, mapMC, runConduit, sinkList, takeC, (.|)) +import Control.Monad.Reader.Has (Functor (fmap), Has, Monad ((>>=)), MonadReader, ReaderT (runReaderT), ask, lift) +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.Persist.Sql (SqlBackend) +import Database.Queries ( + collateVersions, + getCategoriesFor, + getDependencyVersions, + getPkgDataSource, + getPkgDependencyData, + serviceQuerySource, + ) +import Foundation (Handler, Route (InstructionsR, LicenseR)) +import Handler.Types.Api (ApiVersion (..)) +import Handler.Util (basicRender) +import Lib.Error (S9Error (..)) +import Lib.PkgRepository (PkgRepo, getIcon, getManifest) +import Lib.Types.Core (PkgId) +import Lib.Types.Emver (Version, VersionRange (..), parseRange, satisfies, (<||)) +import Model (Category (..), Key (..), PkgDependency (..), VersionRecord (..)) +import Network.HTTP.Types (status400) +import Protolude.Unsafe (unsafeFromJust) +import Settings (AppSettings) +import Startlude ( + Applicative ((*>)), + Bifunctor (..), + Bool (..), + ByteString, + ConvertText (toS), + Down (..), + Either (..), + Eq (..), + Generic, + Int, + Maybe (..), + MonadIO, + NonEmpty, + Num ((*), (-)), + Show, + Text, + Traversable (traverse), + catMaybes, + const, + encodeUtf8, + filter, + flip, + for, + fromMaybe, + headMay, + id, + mappend, + maximumOn, + nonEmpty, + note, + pure, + readMaybe, + snd, + sortOn, + zipWith, + zipWithM, + ($), + (&&&), + (.), + (.*), + (<$>), + (<&>), + (<>), + (=<<), + ) +import UnliftIO (Concurrently (..), mapConcurrently) +import Yesod ( + MonadLogger, + MonadResource, + ToContent (..), + ToTypedContent (..), + YesodPersist (runDB), + lookupGetParam, + sendResponseStatus, + ) +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 :: !(NonEmpty 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 + ] + + +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] + + +data PackageMetadata = PackageMetadata + { packageMetadataPkgId :: !PkgId + , packageMetadataPkgVersionRecords :: !(NonEmpty VersionRecord) + , packageMetadataPkgVersion :: !Version + , packageMetadataPkgCategories :: ![Category] + } + deriving (Eq, Show) + + +getPackageIndexR :: Handler PackageListRes +getPackageIndexR = do + osPredicate <- + getOsVersionQuery <&> \case + Nothing -> const True + Just v -> flip satisfies v + pkgIds <- getPkgIdsQuery + category <- getCategoryQuery + page <- fromMaybe 1 <$> getPageQuery + limit' <- fromMaybe 20 <$> getLimitQuery + query <- T.strip . fromMaybe "" <$> lookupGetParam "query" + let (source, packageRanges) = case pkgIds of + Nothing -> (serviceQuerySource category query, const Any) + Just packages -> + let s = getPkgDataSource (packageReqId <$> packages) + r = fromMaybe None . (flip lookup $ (packageReqId &&& packageReqVersion) <$> packages) + in (s, r) + filteredPackages <- + runDB $ + runConduit $ + source + -- group conduit pipeline by pkg id + .| collateVersions + -- 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) + -- pages start at 1 for some reason. TODO: make pages start at 0 + .| (dropC (limit' * (page - 1)) *> takeC limit') + .| 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 <$> runConcurrently (zipWithM (Concurrently .* constructPackageListApiRes) filteredPackages pkgsWithDependencies) + + +parseQueryParam :: Text -> (Text -> Either Text a) -> Handler (Maybe a) +parseQueryParam param parser = do + lookupGetParam param >>= \case + Nothing -> pure Nothing + Just x -> case parser x of + Left e -> do + let err = InvalidParamsE ("get:" <> param) x + $logWarn e + sendResponseStatus status400 err + Right a -> pure (Just a) + + +getPkgIdsQuery :: Handler (Maybe [PackageReq]) +getPkgIdsQuery = parseQueryParam "ids" (first toS . eitherDecodeStrict . encodeUtf8) + + +getCategoryQuery :: Handler (Maybe Text) +getCategoryQuery = parseQueryParam "category" ((flip $ note . mappend "Invalid 'category': ") =<< (readMaybe . T.toUpper)) + + +getPageQuery :: Handler (Maybe Int) +getPageQuery = parseQueryParam "page" ((flip $ note . mappend "Invalid 'page': ") =<< readMaybe) + + +getLimitQuery :: Handler (Maybe Int) +getLimitQuery = parseQueryParam "per-page" ((flip $ note . mappend "Invalid 'per-page': ") =<< readMaybe) + + +getOsVersionQuery :: Handler (Maybe VersionRange) +getOsVersionQuery = parseQueryParam "eos-version-compat" (first toS . Atto.parseOnly parseRange) + + +getPackageDependencies :: + (MonadIO m, MonadLogger m, MonadResource m, Has PkgRepo r, MonadReader r m) => + (Version -> Bool) -> + PackageMetadata -> + ReaderT SqlBackend m (HashMap PkgId DependencyRes) +getPackageDependencies osPredicate PackageMetadata{packageMetadataPkgId = pkg, packageMetadataPkgVersion = pkgVersion} = + do + pkgDepInfo <- getPkgDependencyData pkg pkgVersion + pkgDepInfoWithVersions <- traverse getDependencyVersions pkgDepInfo + let compatiblePkgDepInfo = fmap (filter (osPredicate . versionRecordOsVersion)) pkgDepInfoWithVersions + let depMetadata = catMaybes $ zipWith selectDependencyBestVersion pkgDepInfo compatiblePkgDepInfo + lift $ + fmap HM.fromList $ + for depMetadata $ \(depId, title, v) -> do + icon <- encodeBase64 <$> loadIcon depId v + pure $ (depId, DependencyRes title icon) + + +constructPackageListApiRes :: + (MonadResource m, MonadReader r m, Has AppSettings r, Has PkgRepo r) => + PackageMetadata -> + HashMap PkgId DependencyRes -> + m PackageRes +constructPackageListApiRes PackageMetadata{..} dependencies = do + settings <- ask @_ @_ @AppSettings + let pkgId = packageMetadataPkgId + let pkgCategories = packageMetadataPkgCategories + let pkgVersions = packageMetadataPkgVersionRecords + let pkgVersion = packageMetadataPkgVersion + manifest <- + flip runReaderT settings $ + (snd <$> getManifest pkgId pkgVersion) >>= \bs -> + runConduit $ bs .| CL.foldMap LBS.fromStrict + icon <- loadIcon pkgId pkgVersion + 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 V0 pkgId + , packageResLicense = basicRender $ LicenseR V0 pkgId + , packageResVersions = versionRecordNumber <$> pkgVersions + , packageResDependencies = dependencies + } + + +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 + + +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 + + +-- get best version of the dependency based on what is specified in the db (ie. what is specified in the manifest for the package) +selectDependencyBestVersion :: PkgDependency -> [VersionRecord] -> Maybe (PkgId, Text, Version) +selectDependencyBestVersion pkgDepRecord depVersions = do + let depId = pkgDependencyDepId pkgDepRecord + let versionRequirement = pkgDependencyDepVersionRange pkgDepRecord + let satisfactory = filter ((<|| versionRequirement) . versionRecordNumber) depVersions + case maximumOn versionRecordNumber satisfactory of + Just bestVersion -> Just (unPkgRecordKey depId, versionRecordTitle bestVersion, versionRecordNumber bestVersion) + Nothing -> Nothing diff --git a/src/Handler/Package/V0/Info.hs b/src/Handler/Package/V0/Info.hs new file mode 100644 index 0000000..6b7d688 --- /dev/null +++ b/src/Handler/Package/V0/Info.hs @@ -0,0 +1,33 @@ +module Handler.Package.V0.Info where + +import Data.Aeson (ToJSON (..)) +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 + { name :: !Text + , categories :: ![Text] + } + deriving (Show, Generic) +instance ToJSON InfoRes +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/Instructions.hs b/src/Handler/Package/V0/Instructions.hs new file mode 100644 index 0000000..334d0e7 --- /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.Core (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..70e63d9 --- /dev/null +++ b/src/Handler/Package/V0/Latest.hs @@ -0,0 +1,48 @@ +module Handler.Package.V0.Latest where + +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.Queries (fetchLatestApp) +import Foundation (Handler) +import Lib.Error (S9Error (..)) +import Lib.Types.Core (PkgId) +import Lib.Types.Emver (Version) +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)) + deriving (Show, Generic) +instance ToJSON VersionLatestRes +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 new file mode 100644 index 0000000..b0fe763 --- /dev/null +++ b/src/Handler/Package/V0/License.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Handler.Package.V0.License 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, getLicense) +import Lib.Types.Core (PkgId) +import Network.HTTP.Types (status400) +import Startlude (show, ($)) +import Yesod (TypedContent, addHeader, respondSource, sendChunkBS, sendResponseStatus, typePlain) + + +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..e5142df --- /dev/null +++ b/src/Handler/Package/V0/Manifest.hs @@ -0,0 +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.Core (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 new file mode 100644 index 0000000..cd12db7 --- /dev/null +++ b/src/Handler/Package/V0/ReleaseNotes.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE RecordWildCards #-} + +module Handler.Package.V0.ReleaseNotes where + +import Data.Aeson (ToJSON (..)) +import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict qualified as HM +import Database.Queries (fetchAllAppVersions) +import Foundation (Handler, RegistryCtx (..)) +import Lib.Types.Core (PkgId) +import Lib.Types.Emver (Version) +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} + 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 + + +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 new file mode 100644 index 0000000..8ac89d4 --- /dev/null +++ b/src/Handler/Package/V0/S9PK.hs @@ -0,0 +1,49 @@ +{-# 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, 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.Core (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 + 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 new file mode 100644 index 0000000..5338cb6 --- /dev/null +++ b/src/Handler/Package/V0/Version.hs @@ -0,0 +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.Core (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 new file mode 100644 index 0000000..e04d67e --- /dev/null +++ b/src/Handler/Types/Api.hs @@ -0,0 +1,36 @@ +module Handler.Types.Api where + +import GHC.Read (Read (..)) +import GHC.Show (show) +import Startlude ( + Eq, + Maybe (..), + Ord, + 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 _ "v0" = [(V0, "")] + readsPrec _ "v1" = [(V1, "")] + 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/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 new file mode 100644 index 0000000..f9ca712 --- /dev/null +++ b/src/Handler/Util.hs @@ -0,0 +1,103 @@ +{-# 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.Core (PkgId) +import Lib.Types.Emver ( + Version, + VersionRange, + ) +import Network.HTTP.Types ( + Status, + status400, + ) +import Startlude ( + Bool (..), + Either (..), + Foldable (foldMap), + Maybe (..), + Monoid (..), + Semigroup ((<>)), + Text, + decodeUtf8, + fromMaybe, + fst, + isSpace, + not, + pure, + readMaybe, + ($), + (.), + (<$>), + (>>=), + ) +import UnliftIO (MonadUnliftIO) +import Yesod ( + MonadHandler, + RenderRoute (..), + TypedContent (..), + lookupGetParam, + sendResponseStatus, + toContent, + typePlain, + ) +import Yesod.Core (addHeader) + + +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 + + +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 925c098..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 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 - ) - -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/External/AppMgr.hs b/src/Lib/External/AppMgr.hs index ea88921..4caa398 100644 --- a/src/Lib/External/AppMgr.hs +++ b/src/Lib/External/AppMgr.hs @@ -1,158 +1,148 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} -module Lib.External.AppMgr where +module Lib.External.AppMgr ( + sourceManifest, + getPackageHash, + sourceInstructions, + sourceLicense, + sourceIcon, +) where -import Startlude ( ($) - , (&&) - , (<$>) - , Applicative((*>), pure) - , ByteString - , Eq((==)) - , ExitCode - , FilePath - , Monad - , MonadIO(..) - , Monoid - , String - , atomically - , id - , liftA3 - , stderr - , throwIO - ) +import Startlude ( + Applicative (pure, (*>)), + ByteString, + Eq ((==)), + FilePath, + String, + id, + stderr, + throwIO, + ($), + (&&), + ) -import qualified Data.ByteString.Lazy as LBS -import Data.String.Interpolate.IsString - ( i ) -import System.Process.Typed ( ExitCodeException(eceExitCode) - , Process - , ProcessConfig - , byteStringInput - , byteStringOutput - , getStderr - , getStdout - , proc - , setEnvInherit - , setStderr - , setStdin - , setStdout - , startProcess - , stopProcess - , useHandleOpen - , waitExitCodeSTM - , withProcessWait - ) +import Data.ByteString.Lazy qualified as LBS +import Data.String.Interpolate.IsString ( + i, + ) +import System.Process.Typed ( + ExitCodeException (eceExitCode), + Process, + ProcessConfig, + byteStringInput, + getStdout, + proc, + setEnvInherit, + setStderr, + setStdin, + setStdout, + startProcess, + stopProcess, + useHandleOpen, + ) -import Conduit ( (.|) - , ConduitT - , runConduit - ) -import Control.Monad.Logger ( MonadLoggerIO - , logErrorSH - ) -import qualified Data.Conduit.List as CL -import Data.Conduit.Process.Typed ( createSource ) -import GHC.IO.Exception ( IOErrorType(NoSuchThing) - , IOException(ioe_description, ioe_type) - ) -import Lib.Error ( S9Error(AppMgrE) ) -import System.FilePath ( () ) -import UnliftIO ( MonadUnliftIO - , bracket - , catch - ) +import Conduit ( + ConduitT, + runConduit, + (.|), + ) +import Control.Monad.Logger ( + MonadLoggerIO, + logErrorSH, + ) +import Data.Conduit.List qualified as CL +import Data.Conduit.Process.Typed (createSource) +import GHC.IO.Exception ( + IOErrorType (NoSuchThing), + IOException (ioe_description, ioe_type), + ) +import Lib.Error (S9Error (AppMgrE)) +import System.FilePath (()) +import UnliftIO ( + MonadUnliftIO, + bracket, + catch, + ) -readProcessWithExitCode' :: MonadIO m => String -> [String] -> ByteString -> m (ExitCode, ByteString, ByteString) -readProcessWithExitCode' a b c = liftIO $ do - let pc = - setStdin (byteStringInput $ LBS.fromStrict c) - $ setStderr byteStringOutput - $ setEnvInherit - $ setStdout byteStringOutput - $ System.Process.Typed.proc a b - withProcessWait pc $ \process -> atomically $ liftA3 (,,) - (waitExitCodeSTM process) - (LBS.toStrict <$> getStdout process) - (LBS.toStrict <$> getStderr process) -readProcessInheritStderr :: forall m a - . MonadUnliftIO m - => String - -> [String] - -> ByteString - -> (ConduitT () ByteString m () -> m a) -- this is because we can't clean up the process in the unCPS'ed version of this - -> m a +readProcessInheritStderr :: + forall m a. + MonadUnliftIO m => + String -> + [String] -> + ByteString -> + (ConduitT () ByteString m () -> m a) -> -- this is because we can't clean up the process in the unCPS'ed version of this + m a readProcessInheritStderr a b c sink = do let pc = - setStdin (byteStringInput $ LBS.fromStrict c) - $ setEnvInherit - $ setStderr (useHandleOpen stderr) - $ setStdout createSource - $ System.Process.Typed.proc a b + setStdin (byteStringInput $ LBS.fromStrict c) $ + setEnvInherit $ + setStderr (useHandleOpen stderr) $ + setStdout createSource $ + System.Process.Typed.proc a b withProcessTerm' pc $ \p -> sink (getStdout p) where -- We need this to deal with https://github.com/haskell/process/issues/215 - withProcessTerm' :: (MonadUnliftIO m) - => ProcessConfig stdin stdout stderr - -> (Process stdin stdout stderr -> m a) - -> m a + withProcessTerm' :: + (MonadUnliftIO m) => + ProcessConfig stdin stdout stderr -> + (Process stdin stdout stderr -> m a) -> + m a withProcessTerm' cfg = bracket (startProcess cfg) $ \p -> do stopProcess p - `catch` (\e -> if ioe_type e == NoSuchThing && ioe_description e == "No child processes" - then pure () - else throwIO e + `catch` ( \e -> + if ioe_type e == NoSuchThing && ioe_description e == "No child processes" + then pure () + else throwIO e ) -sourceManifest :: (MonadUnliftIO m, MonadLoggerIO m) - => FilePath - -> FilePath - -> (ConduitT () ByteString m () -> m r) - -> m r + +sourceManifest :: + (MonadUnliftIO m, MonadLoggerIO m) => + FilePath -> + FilePath -> + (ConduitT () ByteString m () -> m r) -> + m r sourceManifest appmgrPath pkgFile sink = do let appmgr = readProcessInheritStderr (appmgrPath "embassy-sdk") ["inspect", "manifest", pkgFile] "" appmgr sink `catch` \ece -> $logErrorSH ece *> throwIO (AppMgrE [i|embassy-sdk inspect manifest #{pkgFile}|] (eceExitCode ece)) + sourceIcon :: (MonadUnliftIO m, MonadLoggerIO m) => FilePath -> FilePath -> (ConduitT () ByteString m () -> m r) -> m r sourceIcon appmgrPath pkgFile sink = do let appmgr = readProcessInheritStderr (appmgrPath "embassy-sdk") ["inspect", "icon", pkgFile] "" appmgr sink `catch` \ece -> $logErrorSH ece *> throwIO (AppMgrE [i|embassy-sdk inspect icon #{pkgFile}|] (eceExitCode ece)) + getPackageHash :: (MonadUnliftIO m, MonadLoggerIO m) => FilePath -> FilePath -> m ByteString getPackageHash appmgrPath pkgFile = do let appmgr = readProcessInheritStderr (appmgrPath "embassy-sdk") ["inspect", "hash", pkgFile] "" appmgr (\bsSource -> runConduit $ bsSource .| CL.foldMap id) `catch` \ece -> $logErrorSH ece *> throwIO (AppMgrE [i|embassy-sdk inspect hash #{pkgFile}|] (eceExitCode ece)) -sourceInstructions :: (MonadUnliftIO m, MonadLoggerIO m) - => FilePath - -> FilePath - -> (ConduitT () ByteString m () -> m r) - -> m r + +sourceInstructions :: + (MonadUnliftIO m, MonadLoggerIO m) => + FilePath -> + FilePath -> + (ConduitT () ByteString m () -> m r) -> + m r sourceInstructions appmgrPath pkgFile sink = do let appmgr = readProcessInheritStderr (appmgrPath "embassy-sdk") ["inspect", "instructions", pkgFile] "" appmgr sink `catch` \ece -> $logErrorSH ece *> throwIO (AppMgrE [i|embassy-sdk inspect instructions #{pkgFile}|] (eceExitCode ece)) -sourceLicense :: (MonadUnliftIO m, MonadLoggerIO m) - => FilePath - -> FilePath - -> (ConduitT () ByteString m () -> m r) - -> m r + +sourceLicense :: + (MonadUnliftIO m, MonadLoggerIO m) => + FilePath -> + FilePath -> + (ConduitT () ByteString m () -> m r) -> + m r sourceLicense appmgrPath pkgFile sink = do let appmgr = readProcessInheritStderr (appmgrPath "embassy-sdk") ["inspect", "license", pkgFile] "" appmgr sink `catch` \ece -> $logErrorSH ece *> throwIO (AppMgrE [i|embassy-sdk inspect license #{pkgFile}|] (eceExitCode ece)) - -sinkMem :: (Monad m, Monoid a) => ConduitT () a m () -> m a -sinkMem c = runConduit $ c .| CL.foldMap id diff --git a/src/Lib/PkgRepository.hs b/src/Lib/PkgRepository.hs index c861d99..4b5a701 100644 --- a/src/Lib/PkgRepository.hs +++ b/src/Lib/PkgRepository.hs @@ -1,180 +1,199 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} -{-# LANGUAGE GADTs #-} module Lib.PkgRepository where -import Conduit ( (.|) - , ConduitT - , MonadResource - , runConduit - , runResourceT - , sinkFileCautious - , sourceFile - ) -import Control.Monad.Logger ( MonadLogger - , MonadLoggerIO - , logError - , logInfo - , logWarn - ) -import Control.Monad.Reader.Has ( Has - , ask - , asks - ) -import Crypto.Hash ( SHA256 ) -import Crypto.Hash.Conduit ( hashFile ) -import Data.Aeson ( eitherDecodeFileStrict' ) -import qualified Data.Attoparsec.Text as Atto -import Data.Attoparsec.Text ( parseOnly ) -import Data.ByteArray.Encoding ( Base(Base16) - , convertToBase - ) -import Data.ByteString ( readFile - , writeFile - ) -import qualified Data.HashMap.Strict as HM -import Data.String.Interpolate.IsString - ( i ) -import qualified Data.Text as T -import Data.Time ( getCurrentTime ) -import Database.Esqueleto.Experimental - ( ConnectionPool - , insertUnique - , runSqlPool - ) -import Database.Persist ( (=.) - , insertKey - , update - , upsert - ) -import Database.Persist.Sql ( SqlPersistT - , runSqlPoolNoTransaction - ) -import Database.PostgreSQL.Simple ( SqlError(sqlState) ) -import Lib.Error ( S9Error(NotFoundE) ) -import qualified Lib.External.AppMgr as AppMgr -import Lib.Types.AppIndex ( PackageDependency(..) - , PackageManifest(..) - , PkgId(..) - , packageDependencyVersion - , packageManifestDependencies - ) -import Lib.Types.Emver ( Version - , VersionRange - , parseVersion - , satisfies - ) -import Model ( EntityField(EosHashHash, PkgRecordUpdatedAt) - , EosHash(EosHash) - , Key(PkgRecordKey) - , PkgDependency(PkgDependency) - , PkgRecord(PkgRecord) - ) -import Startlude ( ($) - , (&&) - , (.) - , (/=) - , (<$>) - , Bool(..) - , ByteString - , Down(..) - , Either(..) - , Eq((==)) - , Exception - , FilePath - , IO - , Integer - , Maybe(..) - , MonadIO(liftIO) - , MonadReader - , Ord(compare) - , Show - , SomeException(..) - , decodeUtf8 - , filter - , find - , first - , flip - , for_ - , fst - , headMay - , not - , on - , partitionEithers - , pure - , show - , snd - , sortBy - , throwIO - , toS - , void - ) -import System.FSNotify ( ActionPredicate - , Event(..) - , eventPath - , watchTree - , withManager - ) -import System.FilePath ( (<.>) - , () - , takeBaseName - , takeDirectory - , takeExtension - , takeFileName - ) -import UnliftIO ( MonadUnliftIO - , askRunInIO - , async - , catch - , mapConcurrently_ - , newEmptyMVar - , takeMVar - , tryPutMVar - , wait - ) -import UnliftIO.Concurrent ( forkIO ) -import UnliftIO.Directory ( doesDirectoryExist - , doesPathExist - , getFileSize - , listDirectory - , removeFile - , renameFile - ) -import UnliftIO.Exception ( handle ) -import Yesod.Core.Content ( typeGif - , typeJpeg - , typePlain - , typePng - , typeSvg - ) -import Yesod.Core.Types ( ContentType ) +import Conduit ( + ConduitT, + MonadResource, + runConduit, + runResourceT, + sinkFileCautious, + sourceFile, + (.|), + ) +import Control.Monad.Logger ( + MonadLogger, + MonadLoggerIO, + logError, + logInfo, + logWarn, + ) +import Control.Monad.Reader.Has ( + Has, + ask, + asks, + ) +import Crypto.Hash (SHA256) +import Crypto.Hash.Conduit (hashFile) +import Data.Aeson (eitherDecodeFileStrict') +import Data.Attoparsec.Text (parseOnly) +import Data.Attoparsec.Text qualified as Atto +import Data.ByteArray.Encoding ( + Base (Base16), + convertToBase, + ) +import Data.ByteString ( + readFile, + writeFile, + ) +import Data.HashMap.Strict qualified as HM +import Data.String.Interpolate.IsString ( + i, + ) +import Data.Text qualified as T +import Data.Time (getCurrentTime) +import Database.Esqueleto.Experimental ( + ConnectionPool, + insertUnique, + runSqlPool, + ) +import Database.Persist ( + insertKey, + update, + upsert, + (=.), + ) +import Database.Persist.Sql ( + SqlPersistT, + runSqlPoolNoTransaction, + ) +import Database.PostgreSQL.Simple (SqlError (sqlState)) +import Lib.Error (S9Error (NotFoundE)) +import Lib.External.AppMgr qualified as AppMgr +import Lib.Types.Core ( + PkgId (..), + ) +import Lib.Types.Emver ( + Version, + VersionRange, + parseVersion, + satisfies, + ) +import Lib.Types.Manifest (PackageDependency (..), PackageManifest (..)) +import Model ( + EntityField (EosHashHash, PkgRecordUpdatedAt), + EosHash (EosHash), + Key (PkgRecordKey), + PkgDependency (PkgDependency), + PkgRecord (PkgRecord), + ) +import Startlude ( + Bool (..), + ByteString, + Down (..), + Either (..), + Eq ((==)), + Exception, + FilePath, + IO, + Integer, + Maybe (..), + MonadIO (liftIO), + MonadReader, + Ord (compare), + Show, + SomeException (..), + decodeUtf8, + filter, + find, + first, + flip, + for_, + fst, + headMay, + not, + on, + partitionEithers, + pure, + show, + snd, + sortBy, + throwIO, + toS, + void, + ($), + (&&), + (.), + (/=), + (<$>), + ) +import System.FSNotify ( + ActionPredicate, + Event (..), + eventPath, + watchTree, + withManager, + ) +import System.FilePath ( + takeBaseName, + takeDirectory, + takeExtension, + takeFileName, + (<.>), + (), + ) +import UnliftIO ( + MonadUnliftIO, + askRunInIO, + async, + catch, + mapConcurrently_, + newEmptyMVar, + takeMVar, + tryPutMVar, + wait, + ) +import UnliftIO.Concurrent (forkIO) +import UnliftIO.Directory ( + doesDirectoryExist, + doesPathExist, + getFileSize, + listDirectory, + removeFile, + renameFile, + ) +import UnliftIO.Exception (handle) +import Yesod.Core.Content ( + typeGif, + typeJpeg, + typePlain, + typePng, + typeSvg, + ) +import Yesod.Core.Types (ContentType) + newtype ManifestParseException = ManifestParseException FilePath - deriving Show + deriving (Show) instance Exception ManifestParseException + data PkgRepo = PkgRepo - { pkgRepoFileRoot :: !FilePath + { pkgRepoFileRoot :: !FilePath , pkgRepoAppMgrBin :: !FilePath } + newtype EosRepo = EosRepo { eosRepoFileRoot :: FilePath } + getPackages :: (MonadIO m, MonadReader r m, Has PkgRepo r) => m [PkgId] getPackages = do - root <- asks pkgRepoFileRoot + root <- asks pkgRepoFileRoot paths <- listDirectory root pure $ PkgId . toS <$> paths + getVersionsFor :: (MonadIO m, MonadReader r m, Has PkgRepo r, MonadLogger m) => PkgId -> m [Version] getVersionsFor pkg = do root <- asks pkgRepoFileRoot @@ -188,52 +207,66 @@ getVersionsFor pkg = do pure successes else pure [] + getViableVersions :: (MonadIO m, MonadReader r m, Has PkgRepo r, MonadLogger m) => PkgId -> VersionRange -> m [Version] getViableVersions pkg spec = filter (`satisfies` spec) <$> getVersionsFor pkg -getBestVersion :: (MonadIO m, MonadReader r m, Has PkgRepo r, MonadLogger m) - => PkgId - -> VersionRange - -> Bool - -> m (Maybe Version) + +getBestVersion :: + (MonadIO m, MonadReader r m, Has PkgRepo r, MonadLogger m) => + PkgId -> + VersionRange -> + Bool -> + m (Maybe Version) getBestVersion pkg spec preferMin = headMay . sortBy comparator <$> getViableVersions pkg spec - where comparator = if preferMin then compare else compare `on` Down + where + comparator = if preferMin then compare else compare `on` Down + loadPkgDependencies :: MonadUnliftIO m => ConnectionPool -> PackageManifest -> m () loadPkgDependencies appConnPool manifest = do - let pkgId = packageManifestId manifest + let pkgId = packageManifestId manifest let pkgVersion = packageManifestVersion manifest - let deps = packageManifestDependencies manifest + let deps = packageManifestDependencies manifest time <- liftIO getCurrentTime - _ <- runWith appConnPool $ insertKey (PkgRecordKey pkgId) (PkgRecord time Nothing) `catch` \(e :: SqlError) -> - -- 23505 is "already exists" - if sqlState e == "23505" then update (PkgRecordKey pkgId) [PkgRecordUpdatedAt =. Just time] else throwIO e + _ <- + runWith appConnPool $ + insertKey (PkgRecordKey pkgId) (PkgRecord time Nothing) `catch` \(e :: SqlError) -> + -- 23505 is "already exists" + if sqlState e == "23505" then update (PkgRecordKey pkgId) [PkgRecordUpdatedAt =. Just time] else throwIO e let deps' = first PkgRecordKey <$> HM.toList deps for_ deps' - (\d -> flip runSqlPool appConnPool $ do - _ <- runWith appConnPool $ insertKey (fst d) (PkgRecord time Nothing) `catch` \(e :: SqlError) -> - -- 23505 is "already exists" - if sqlState e == "23505" then update (fst d) [PkgRecordUpdatedAt =. Just time] else throwIO e - insertUnique - $ PkgDependency time (PkgRecordKey pkgId) pkgVersion (fst d) (packageDependencyVersion . snd $ d) + ( \d -> flip runSqlPool appConnPool $ do + _ <- + runWith appConnPool $ + insertKey (fst d) (PkgRecord time Nothing) `catch` \(e :: SqlError) -> + -- 23505 is "already exists" + if sqlState e == "23505" then update (fst d) [PkgRecordUpdatedAt =. Just time] else throwIO e + insertUnique $ + PkgDependency time (PkgRecordKey pkgId) pkgVersion (fst d) (packageDependencyVersion . snd $ d) ) where runWith :: MonadUnliftIO m => ConnectionPool -> SqlPersistT m a -> m a runWith pool action = runSqlPoolNoTransaction action pool Nothing + -- extract all package assets into their own respective files extractPkg :: (MonadUnliftIO m, MonadReader r m, Has PkgRepo r, MonadLoggerIO m) => ConnectionPool -> FilePath -> m () extractPkg pool fp = handle @_ @SomeException cleanup $ do $logInfo [i|Extracting package: #{fp}|] - PkgRepo { pkgRepoAppMgrBin = appmgr } <- ask + PkgRepo{pkgRepoAppMgrBin = appmgr} <- ask let pkgRoot = takeDirectory fp - manifestTask <- async $ runResourceT $ AppMgr.sourceManifest appmgr fp $ sinkIt (pkgRoot "manifest.json") - pkgHashTask <- async $ AppMgr.getPackageHash appmgr fp - instructionsTask <- async $ runResourceT $ AppMgr.sourceInstructions appmgr fp $ sinkIt - (pkgRoot "instructions.md") + manifestTask <- async $ runResourceT $ AppMgr.sourceManifest appmgr fp $ sinkIt (pkgRoot "manifest.json") + pkgHashTask <- async $ AppMgr.getPackageHash appmgr fp + instructionsTask <- + async $ + runResourceT $ + AppMgr.sourceInstructions appmgr fp $ + sinkIt + (pkgRoot "instructions.md") licenseTask <- async $ runResourceT $ AppMgr.sourceLicense appmgr fp $ sinkIt (pkgRoot "license.md") - iconTask <- async $ runResourceT $ AppMgr.sourceIcon appmgr fp $ sinkIt (pkgRoot "icon.tmp") + iconTask <- async $ runResourceT $ AppMgr.sourceIcon appmgr fp $ sinkIt (pkgRoot "icon.tmp") wait manifestTask eManifest <- liftIO (eitherDecodeFileStrict' (pkgRoot "manifest.json")) case eManifest of @@ -242,11 +275,12 @@ extractPkg pool fp = handle @_ @SomeException cleanup $ do liftIO . throwIO $ ManifestParseException (pkgRoot "manifest.json") Right manifest -> do wait iconTask - let iconDest = "icon" <.> case packageManifestIcon manifest of - Nothing -> "png" - Just x -> case takeExtension (T.unpack x) of - "" -> "png" - other -> other + let iconDest = + "icon" <.> case packageManifestIcon manifest of + Nothing -> "png" + Just x -> case takeExtension (T.unpack x) of + "" -> "png" + other -> other loadPkgDependencies pool manifest liftIO $ renameFile (pkgRoot "icon.tmp") (pkgRoot iconDest) hash <- wait pkgHashTask @@ -263,97 +297,112 @@ extractPkg pool fp = handle @_ @SomeException cleanup $ do mapConcurrently_ (removeFile . (pkgRoot )) toRemove throwIO e + watchEosRepoRoot :: (MonadUnliftIO m, MonadReader r m, Has EosRepo r, MonadLoggerIO m) => ConnectionPool -> m (IO Bool) watchEosRepoRoot pool = do $logInfo "Starting FSNotify Watch Manager: EOS" - root <- asks eosRepoFileRoot + root <- asks eosRepoFileRoot runInIO <- askRunInIO - box <- newEmptyMVar @_ @() - _ <- forkIO $ liftIO $ withManager $ \watchManager -> do - stop <- watchTree watchManager root shouldIndex $ \evt -> do - let os = eventPath evt - void . forkIO $ runInIO $ do - indexOs pool os - takeMVar box - stop + box <- newEmptyMVar @_ @() + _ <- forkIO $ + liftIO $ + withManager $ \watchManager -> do + stop <- watchTree watchManager root shouldIndex $ \evt -> do + let os = eventPath evt + void . forkIO $ + runInIO $ do + indexOs pool os + takeMVar box + stop pure $ tryPutMVar box () where shouldIndex :: ActionPredicate - shouldIndex (Added path _ isDir) = not isDir && takeExtension path == ".img" + shouldIndex (Added path _ isDir) = not isDir && takeExtension path == ".img" shouldIndex (Modified path _ isDir) = not isDir && takeExtension path == ".img" - shouldIndex _ = False + shouldIndex _ = False indexOs :: (MonadUnliftIO m, MonadLoggerIO m) => ConnectionPool -> FilePath -> m () indexOs pool path = do hash <- hashFile @_ @SHA256 path let hashText = decodeUtf8 $ convertToBase Base16 hash - let vText = takeFileName (takeDirectory path) + let vText = takeFileName (takeDirectory path) let eVersion = parseOnly parseVersion . T.pack $ vText case eVersion of Left e -> $logError [i|Invalid Version Number (#{vText}): #{e}|] Right version -> void $ flip runSqlPool pool $ upsert (EosHash version hashText) [EosHashHash =. hashText] + getManifestLocation :: (MonadReader r m, Has PkgRepo r) => PkgId -> Version -> m FilePath getManifestLocation pkg version = do root <- asks pkgRepoFileRoot pure $ root show pkg show version "manifest.json" -getManifest :: (MonadResource m, MonadReader r m, Has PkgRepo r) - => PkgId - -> Version - -> m (Integer, ConduitT () ByteString m ()) + +getManifest :: + (MonadResource m, MonadReader r m, Has PkgRepo r) => + PkgId -> + Version -> + m (Integer, ConduitT () ByteString m ()) getManifest pkg version = do manifestPath <- getManifestLocation pkg version - n <- getFileSize manifestPath + n <- getFileSize manifestPath pure (n, sourceFile manifestPath) -getInstructions :: (MonadResource m, MonadReader r m, Has PkgRepo r) - => PkgId - -> Version - -> m (Integer, ConduitT () ByteString m ()) + +getInstructions :: + (MonadResource m, MonadReader r m, Has PkgRepo r) => + PkgId -> + Version -> + m (Integer, ConduitT () ByteString m ()) getInstructions pkg version = do root <- asks pkgRepoFileRoot let instructionsPath = root show pkg show version "instructions.md" n <- getFileSize instructionsPath pure (n, sourceFile instructionsPath) -getLicense :: (MonadResource m, MonadReader r m, Has PkgRepo r) - => PkgId - -> Version - -> m (Integer, ConduitT () ByteString m ()) + +getLicense :: + (MonadResource m, MonadReader r m, Has PkgRepo r) => + PkgId -> + Version -> + m (Integer, ConduitT () ByteString m ()) getLicense pkg version = do root <- asks pkgRepoFileRoot let licensePath = root show pkg show version "license.md" n <- getFileSize licensePath pure (n, sourceFile licensePath) -getIcon :: (MonadResource m, MonadReader r m, Has PkgRepo r) - => PkgId - -> Version - -> m (ContentType, Integer, ConduitT () ByteString m ()) + +getIcon :: + (MonadResource m, MonadReader r m, Has PkgRepo r) => + PkgId -> + Version -> + m (ContentType, Integer, ConduitT () ByteString m ()) getIcon pkg version = do root <- asks pkgRepoFileRoot let pkgRoot = root show pkg show version mIconFile <- find ((== "icon") . takeBaseName) <$> listDirectory pkgRoot case mIconFile of Nothing -> throwIO $ NotFoundE [i|#{pkg}: Icon|] - Just x -> do + Just x -> do let ct = case takeExtension x of - ".png" -> typePng - ".jpg" -> typeJpeg + ".png" -> typePng + ".jpg" -> typeJpeg ".jpeg" -> typeJpeg - ".svg" -> typeSvg - ".gif" -> typeGif - _ -> typePlain + ".svg" -> typeSvg + ".gif" -> typeGif + _ -> typePlain n <- getFileSize (pkgRoot x) pure (ct, n, sourceFile (pkgRoot x)) + getHash :: (MonadIO m, MonadReader r m, Has PkgRepo r) => PkgId -> Version -> m ByteString getHash pkg version = do root <- asks pkgRepoFileRoot let hashPath = root show pkg show version "hash.bin" liftIO $ readFile hashPath + getPackage :: (MonadResource m, MonadReader r m, Has PkgRepo r) => PkgId -> Version -> m (Maybe FilePath) getPackage pkg version = do root <- asks pkgRepoFileRoot 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 deleted file mode 100644 index 4ab7953..0000000 --- a/src/Lib/Types/AppIndex.hs +++ /dev/null @@ -1,267 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralisedNewtypeDeriving #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE QuasiQuotes #-} -module Lib.Types.AppIndex where - -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 } - deriving stock (Eq, Ord) - deriving newtype (FromHttpApiData, ToHttpApiData) -instance IsString PkgId where - fromString = PkgId . fromString -instance P.Show PkgId where - show = toS . unPkgId -instance Read PkgId where - readsPrec _ s = [(PkgId $ toS s, "")] -instance Hashable PkgId where - hashWithSalt n = hashWithSalt n . unPkgId -instance FromJSON PkgId where - parseJSON = fmap PkgId . parseJSON -instance ToJSON PkgId where - toJSON = toJSON . unPkgId -instance FromJSONKey PkgId where - fromJSONKey = fmap PkgId fromJSONKey -instance ToJSONKey PkgId where - toJSONKey = contramap unPkgId toJSONKey -instance PersistField PkgId where - toPersistValue = PersistText . show - fromPersistValue (PersistText t) = Right . PkgId $ toS t - fromPersistValue other = Left [i|Invalid AppId: #{other}|] -instance PersistFieldSql PkgId where - sqlType _ = SqlString -instance PathPiece PkgId where - fromPathPiece = fmap PkgId . fromPathPiece - toPathPiece = unPkgId -data VersionInfo = VersionInfo - { versionInfoVersion :: !Version - , versionInfoReleaseNotes :: !Text - , versionInfoDependencies :: !(HM.HashMap PkgId VersionRange) - , versionInfoOsVersion :: !Version - , versionInfoInstallAlert :: !(Maybe Text) - } - deriving (Eq, Show) - -data PackageDependency = PackageDependency - { packageDependencyOptional :: !(Maybe Text) - , packageDependencyVersion :: !VersionRange - , packageDependencyDescription :: !(Maybe Text) - } - deriving Show -instance FromJSON PackageDependency where - parseJSON = withObject "service dependency info" $ \o -> do - packageDependencyOptional <- o .:? "optional" - packageDependencyVersion <- o .: "version" - packageDependencyDescription <- o .:? "description" - 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 - , packageManifestDescriptionShort :: !Text - , packageManifestReleaseNotes :: !Text - , packageManifestIcon :: !(Maybe Text) - , packageManifestAlerts :: !(HM.HashMap ServiceAlert (Maybe Text)) - , packageManifestDependencies :: !(HM.HashMap PkgId PackageDependency) - , packageManifestEosVersion :: !Version - } - 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") - packageManifestDescriptionShort <- o .: "description" >>= (.: "short") - 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 - alertDesc <- parseJSON value - pure (alertType, alertDesc) - let packageManifestAlerts = HM.fromList a - packageManifestDependencies <- o .: "dependencies" - packageManifestEosVersion <- o .: "eos-version" - pure PackageManifest { .. } - --- >>> eitherDecode testManifest :: Either String PackageManifest -testManifest :: BS.ByteString -testManifest = [i|{ - "id": "embassy-pages", - "title": "Embassy Pages", - "version": "0.1.3", - "description": { - "short": "Create Tor websites, hosted on your Embassy.", - "long": "Embassy Pages is a simple web server that uses directories inside File Browser to serve Tor websites." - }, - "assets": { - "license": "LICENSE", - "icon": "icon.png", - "docker-images": "image.tar", - "instructions": "instructions.md" - }, - "build": [ - "make" - ], - "release-notes": "Upgrade to EmbassyOS v0.3.0", - "license": "nginx", - "wrapper-repo": "https://github.com/Start9Labs/embassy-pages-wrapper", - "upstream-repo": "http://hg.nginx.org/nginx/", - "support-site": null, - "marketing-site": null, - "alerts": { - "install": null, - "uninstall": null, - "restore": null, - "start": null, - "stop": null - }, - "main": { - "type": "docker", - "image": "main", - "system": false, - "entrypoint": "/usr/local/bin/docker_entrypoint.sh", - "args": [], - "mounts": { - "filebrowser": "/mnt/filebrowser" - }, - "io-format": "yaml", - "inject": false, - "shm-size-mb": null - }, - "health-checks": {}, - "config": { - "get": { - "type": "docker", - "image": "compat", - "system": true, - "entrypoint": "config", - "args": [ - "get", - "/root" - ], - "mounts": {}, - "io-format": "yaml", - "inject": false, - "shm-size-mb": null - }, - "set": { - "type": "docker", - "image": "compat", - "system": true, - "entrypoint": "config", - "args": [ - "set", - "/root" - ], - "mounts": {}, - "io-format": "yaml", - "inject": false, - "shm-size-mb": null - } - }, - "volumes": { - "filebrowser": { - "type": "pointer", - "package-id": "filebrowser", - "volume-id": "main", - "path": "/", - "readonly": true - } - }, - "min-os-version": "0.3.0", - "interfaces": { - "main": { - "tor-config": { - "port-mapping": { - "80": "80" - } - }, - "lan-config": null, - "ui": true, - "protocols": [ - "tcp", - "http" - ] - } - }, - "backup": { - "create": { - "type": "docker", - "image": "compat", - "system": true, - "entrypoint": "true", - "args": [], - "mounts": {}, - "io-format": null, - "inject": false, - "shm-size-mb": null - }, - "restore": { - "type": "docker", - "image": "compat", - "system": true, - "entrypoint": "true", - "args": [], - "mounts": {}, - "io-format": null, - "inject": false, - "shm-size-mb": null - } - }, - "migrations": { - "from": {}, - "to": {} - }, - "actions": {}, - "dependencies": { - "filebrowser": { - "version": ">=2.14.1.1 <3.0.0", - "optional": null, - "description": "Used to upload files to serve.", - "critical": false, - "config": null - } - } -}|] diff --git a/src/Lib/Types/Core.hs b/src/Lib/Types/Core.hs new file mode 100644 index 0000000..fe563fa --- /dev/null +++ b/src/Lib/Types/Core.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralisedNewtypeDeriving #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} + +module Lib.Types.Core where + +import Startlude ( + ConvertText (toS), + Either (Left, Right), + Eq ((==)), + Functor (fmap), + Hashable (hashWithSalt), + IsString (..), + KnownSymbol, + Ord, + Proxy (Proxy), + Read, + Show, + String, + Symbol, + Text, + readMaybe, + show, + symbolVal, + ($), + (.), + ) + +import Data.Aeson ( + FromJSON (..), + FromJSONKey (..), + ToJSON (..), + ToJSONKey (..), + ) +import Data.Functor.Contravariant (contramap) +import Data.String.Interpolate.IsString ( + i, + ) +import Database.Persist ( + PersistField (..), + PersistValue (PersistText), + SqlType (..), + ) +import Database.Persist.Sql (PersistFieldSql (sqlType)) +import GHC.Read (Read (readsPrec)) +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 + fromString = PkgId . fromString +instance P.Show PkgId where + show = toS . unPkgId +instance Read PkgId where + readsPrec _ s = [(PkgId $ toS s, "")] +instance Hashable PkgId where + hashWithSalt n = hashWithSalt n . unPkgId +instance FromJSON PkgId where + parseJSON = fmap PkgId . parseJSON +instance ToJSON PkgId where + toJSON = toJSON . unPkgId +instance FromJSONKey PkgId where + fromJSONKey = fmap PkgId fromJSONKey +instance ToJSONKey PkgId where + toJSONKey = contramap unPkgId toJSONKey +instance PersistField PkgId where + toPersistValue = PersistText . show + fromPersistValue (PersistText t) = Right . PkgId $ toS t + fromPersistValue other = Left [i|Invalid AppId: #{other}|] +instance PersistFieldSql PkgId where + sqlType _ = SqlString +instance PathPiece PkgId where + fromPathPiece = fmap PkgId . fromPathPiece + toPathPiece = unPkgId + + +newtype Extension (a :: Symbol) = Extension String deriving (Eq) +type S9PK = Extension "s9pk" +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 + + +extension :: KnownSymbol a => Extension a -> String +extension = symbolVal \ No newline at end of file diff --git a/src/Lib/Types/Manifest.hs b/src/Lib/Types/Manifest.hs new file mode 100644 index 0000000..dc45c5c --- /dev/null +++ b/src/Lib/Types/Manifest.hs @@ -0,0 +1,211 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} + +module Lib.Types.Manifest where + +import Control.Monad.Fail (MonadFail (..)) +import Data.Aeson (FromJSON (..), withObject, (.:), (.:?)) +import Data.HashMap.Internal.Strict (HashMap) +import Data.HashMap.Strict qualified as HM +import Data.String.Interpolate.IsString (i) +import Data.Text qualified as T +import Lib.Types.Core (PkgId) +import Lib.Types.Emver (Version (..), VersionRange) +import Startlude (ByteString, Eq, Generic, Hashable, Maybe (..), Monad ((>>=)), Read, Show, Text, for, pure, readMaybe, ($)) + + +data PackageManifest = PackageManifest + { packageManifestId :: !PkgId + , packageManifestTitle :: !Text + , packageManifestVersion :: !Version + , packageManifestDescriptionLong :: !Text + , packageManifestDescriptionShort :: !Text + , packageManifestReleaseNotes :: !Text + , packageManifestIcon :: !(Maybe Text) + , packageManifestAlerts :: !(HashMap ServiceAlert (Maybe Text)) + , packageManifestDependencies :: !(HashMap PkgId PackageDependency) + , packageManifestEosVersion :: !Version + } + 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") + packageManifestDescriptionShort <- o .: "description" >>= (.: "short") + 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 + alertDesc <- parseJSON value + pure (alertType, alertDesc) + let packageManifestAlerts = HM.fromList a + packageManifestDependencies <- o .: "dependencies" + packageManifestEosVersion <- o .: "eos-version" + pure PackageManifest{..} + + +data PackageDependency = PackageDependency + { packageDependencyOptional :: !(Maybe Text) + , packageDependencyVersion :: !VersionRange + , packageDependencyDescription :: !(Maybe Text) + } + deriving (Show) +instance FromJSON PackageDependency where + parseJSON = withObject "service dependency info" $ \o -> do + packageDependencyOptional <- o .:? "optional" + packageDependencyVersion <- o .: "version" + packageDependencyDescription <- o .:? "description" + pure PackageDependency{..} + + +data ServiceAlert = INSTALL | UNINSTALL | RESTORE | START | STOP + deriving (Show, Eq, Generic, Hashable, Read) + + +-- >>> eitherDecode testManifest :: Either String PackageManifest +testManifest :: ByteString +testManifest = + [i|{ + "id": "embassy-pages", + "title": "Embassy Pages", + "version": "0.1.3", + "description": { + "short": "Create Tor websites, hosted on your Embassy.", + "long": "Embassy Pages is a simple web server that uses directories inside File Browser to serve Tor websites." + }, + "assets": { + "license": "LICENSE", + "icon": "icon.png", + "docker-images": "image.tar", + "instructions": "instructions.md" + }, + "build": [ + "make" + ], + "release-notes": "Upgrade to EmbassyOS v0.3.0", + "license": "nginx", + "wrapper-repo": "https://github.com/Start9Labs/embassy-pages-wrapper", + "upstream-repo": "http://hg.nginx.org/nginx/", + "support-site": null, + "marketing-site": null, + "alerts": { + "install": null, + "uninstall": null, + "restore": null, + "start": null, + "stop": null + }, + "main": { + "type": "docker", + "image": "main", + "system": false, + "entrypoint": "/usr/local/bin/docker_entrypoint.sh", + "args": [], + "mounts": { + "filebrowser": "/mnt/filebrowser" + }, + "io-format": "yaml", + "inject": false, + "shm-size-mb": null + }, + "health-checks": {}, + "config": { + "get": { + "type": "docker", + "image": "compat", + "system": true, + "entrypoint": "config", + "args": [ + "get", + "/root" + ], + "mounts": {}, + "io-format": "yaml", + "inject": false, + "shm-size-mb": null + }, + "set": { + "type": "docker", + "image": "compat", + "system": true, + "entrypoint": "config", + "args": [ + "set", + "/root" + ], + "mounts": {}, + "io-format": "yaml", + "inject": false, + "shm-size-mb": null + } + }, + "volumes": { + "filebrowser": { + "type": "pointer", + "package-id": "filebrowser", + "volume-id": "main", + "path": "/", + "readonly": true + } + }, + "min-os-version": "0.3.0", + "interfaces": { + "main": { + "tor-config": { + "port-mapping": { + "80": "80" + } + }, + "lan-config": null, + "ui": true, + "protocols": [ + "tcp", + "http" + ] + } + }, + "backup": { + "create": { + "type": "docker", + "image": "compat", + "system": true, + "entrypoint": "true", + "args": [], + "mounts": {}, + "io-format": null, + "inject": false, + "shm-size-mb": null + }, + "restore": { + "type": "docker", + "image": "compat", + "system": true, + "entrypoint": "true", + "args": [], + "mounts": {}, + "io-format": null, + "inject": false, + "shm-size-mb": null + } + }, + "migrations": { + "from": {}, + "to": {} + }, + "actions": {}, + "dependencies": { + "filebrowser": { + "version": ">=2.14.1.1 <3.0.0", + "optional": null, + "description": "Used to upload files to serve.", + "critical": false, + "config": null + } + } +}|] \ No newline at end of file diff --git a/src/Model.hs b/src/Model.hs index f1d2888..95ea833 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -1,40 +1,47 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} module Model where -import Crypto.Hash ( Digest - , SHA256 - ) -import Database.Persist.TH ( mkMigrate - , mkPersist - , persistLowerCase - , share - , sqlSettings - ) -import Lib.Types.AppIndex ( PkgId(PkgId) ) -import Lib.Types.Emver ( Version - , VersionRange - ) -import Orphans.Cryptonite ( ) -import Orphans.Emver ( ) -import Startlude ( Eq - , Int - , Show - , Text - , UTCTime - , Word32 - ) +import Crypto.Hash ( + Digest, + SHA256, + ) +import Database.Persist.TH ( + mkMigrate, + mkPersist, + persistLowerCase, + share, + sqlSettings, + ) +import Lib.Types.Core (PkgId (PkgId)) +import Lib.Types.Emver ( + Version, + VersionRange, + ) +import Orphans.Cryptonite () +import Orphans.Emver () +import Startlude ( + Eq, + Int, + Show, + Text, + UTCTime, + Word32, + ) -share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| + +share + [mkPersist sqlSettings, mkMigrate "migrateAll"] + [persistLowerCase| PkgRecord Id PkgId sql=pkg_id createdAt UTCTime diff --git a/src/Startlude.hs b/src/Startlude.hs index ec17f9d..283ada8 100644 --- a/src/Startlude.hs +++ b/src/Startlude.hs @@ -1,33 +1,51 @@ -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 #-} + + +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 + + +{-# INLINE (.*) #-} +infixr 8 .* +(.*) :: (b -> c) -> (a1 -> a2 -> b) -> a1 -> a2 -> c +(.*) = (.) . (.) 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..b7f809e 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,9 @@ 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 # Override default flag values for local packages and extra-deps # flags: {}