diff --git a/.gitignore b/.gitignore index 6297b19..68e722a 100644 --- a/.gitignore +++ b/.gitignore @@ -30,4 +30,9 @@ version **/*.s9pk **/appmgr 0.3.0_features.md -**/embassy-sdk \ No newline at end of file +**/embassy-sdk +start9-registry.prof +start9-registry.hp +start9-registry.pdf +start9-registry.aux +start9-registry.ps \ No newline at end of file diff --git a/config/routes b/config/routes index 827c4a5..eaa6d1d 100644 --- a/config/routes +++ b/config/routes @@ -1,22 +1,15 @@ !/package/#S9PK AppR GET -- get most recent appId at appversion spec, defaults to >=0.0.0 -- ?spec={semver-spec} /package/data CategoriesR GET -- get all marketplace categories /package/index PackageListR GET -- filter marketplace services by various query params -/eos/latest EosR GET -- get eos information +-- /package/updates +/eos/latest EosVersionR GET -- get eos information +/eos/eos.img EosR GET -- get eos.img /latest-version VersionLatestR GET -- get latest version of apps in query param id -/package/manifest/#AppIdentifier AppManifestR GET -- get app manifest from appmgr -- ?version={semver-spec} +/package/manifest/#PkgId AppManifestR GET -- get app manifest from appmgr -- ?version={semver-spec} /package/release-notes ReleaseNotesR GET -- get release notes for package - expects query param of id= -/package/icon/#AppIdentifier IconsR GET -- get icons - can specify version with ?spec= -/package/license/#AppIdentifier LicenseR GET -- get icons - can specify version with ?spec= -/package/instructions/#AppIdentifier InstructionsR GET -- get icons - can specify version with ?spec= - --- TODO confirm needed -/package/config/#AppIdentifier AppConfigR GET -- get app config from appmgr -- ?spec={semver-spec} -/package/version/#Text VersionAppR GET -- get most recent appId version - - --- TODO deprecate -!/sys/#SYS_EXTENSIONLESS SysR GET -- get most recent sys app -- ?spec={semver-spec} -/version VersionR GET -/sys/version/#Text VersionSysR GET -- get most recent sys app version +/package/icon/#PkgId IconsR GET -- get icons - can specify version with ?spec= +/package/license/#PkgId LicenseR GET -- get icons - can specify version with ?spec= +/package/instructions/#PkgId InstructionsR GET -- get icons - can specify version with ?spec= +/package/version/#PkgId PkgVersionR GET -- get most recent appId version /error-logs ErrorLogsR POST \ No newline at end of file diff --git a/package.yaml b/package.yaml index d82d6f5..c24e96c 100644 --- a/package.yaml +++ b/package.yaml @@ -2,60 +2,65 @@ name: start9-registry version: 0.1.0 default-extensions: -- FlexibleInstances -- GeneralizedNewtypeDeriving -- LambdaCase -- MultiWayIf -- NamedFieldPuns -- NoImplicitPrelude -- NumericUnderscores -- OverloadedStrings -- StandaloneDeriving + - FlexibleInstances + - GeneralizedNewtypeDeriving + - LambdaCase + - MultiWayIf + - NamedFieldPuns + - NoImplicitPrelude + - NumericUnderscores + - OverloadedStrings + - StandaloneDeriving dependencies: -- base >=4.12 && <5 -- aeson -- attoparsec -- bytestring -- casing -- conduit -- conduit-extra -- data-default -- directory -- errors -- extra -- file-embed -- fast-logger -- filepath -- http-types -- interpolate -- lens -- monad-logger -- persistent -- persistent-postgresql -- persistent-template -- process -- protolude -- shakespeare -- template-haskell -- text -- time -- transformers -- typed-process -- unordered-containers -- unix -- wai -- wai-cors -- wai-extra -- warp -- warp-tls -- yaml -- yesod -- yesod-core -- yesod-persistent -- esqueleto -- text-conversions -- foreign-store + - base >=4.12 && <5 + - aeson + - ansi-terminal + - attoparsec + - bytestring + - casing + - can-i-haz + - conduit + - conduit-extra + - data-default + - directory + - errors + - esqueleto + - extra + - file-embed + - fast-logger + - filepath + - foreign-store + - fsnotify + - http-types + - interpolate + - lens + - monad-logger + - monad-logger-extras + - parallel + - persistent + - persistent-postgresql + - persistent-template + - process + - protolude + - shakespeare + - template-haskell + - text + - time + - transformers + - typed-process + - unliftio + - unordered-containers + - unix + - wai + - wai-cors + - wai-extra + - warp + - warp-tls + - yaml + - yesod + - yesod-core + - yesod-persistent library: source-dirs: src diff --git a/resources/apps/apps.yaml b/resources/apps/apps.yaml deleted file mode 100644 index ea0e93b..0000000 --- a/resources/apps/apps.yaml +++ /dev/null @@ -1,163 +0,0 @@ -bitcoind: - title: Bitcoin Core - icon-type: png - description: - long: Bitcoin is an innovative payment network and a new kind of money. Bitcoin - uses peer-to-peer technology to operate with no central authority or banks; - managing transactions and the issuing of bitcoins is carried out collectively - by the network. Bitcoin is open-source; its design is public, nobody owns or - controls Bitcoin and everyone can take part. Through many of its unique properties, - Bitcoin allows exciting uses that could not be covered by any previous payment - system. - short: A Bitcoin Full Node by Bitcoin Core - version-info: - - os-version-required: '>=0.2.5' - release-notes: https://github.com/bitcoin/bitcoin/blob/master/doc/release-notes/release-notes-0.20.1.md - dependencies: {} - version: 0.20.1.1 - os-version-recommended: '>=0.2.5' - - os-version-required: '>=0.2.4' - release-notes: https://github.com/bitcoin/bitcoin/blob/master/doc/release-notes/release-notes-0.20.1.md - dependencies: {} - version: 0.20.1 - os-version-recommended: '>=0.2.4' - - os-version-required: '*' - release-notes: https://github.com/bitcoin/bitcoin/blob/master/doc/release-notes/release-notes-0.20.0.md - dependencies: {} - version: 0.20.0 - os-version-recommended: '*' - - os-version-required: '*' - release-notes: https://github.com/bitcoin/bitcoin/blob/master/doc/release-notes/release-notes-0.19.1.md - dependencies: {} - version: 0.19.1 - os-version-recommended: '*' - - os-version-required: '*' - release-notes: https://github.com/bitcoin/bitcoin/blob/master/doc/release-notes/release-notes-0.19.0.1.md - dependencies: {} - version: 0.19.0 - os-version-recommended: '*' - - os-version-required: '*' - release-notes: https://github.com/bitcoin/bitcoin/blob/master/doc/release-notes/release-notes-0.18.1.md - dependencies: {} - version: 0.18.1 - os-version-recommended: '*' -cups: - title: Cups Messenger - icon-type: png - description: - long: Cups is a private, self-hosted, peer-to-peer, Tor-based, instant messenger. - Unlike other end-to-end encrypted messengers, with Cups on the Embassy there - are no trusted third parties. - short: Real private messaging - version-info: - - os-version-required: '>=0.2.4' - release-notes: | - Features - - Adds instructions defined by EmbassyOS 0.2.4 instructions feature - dependencies: {} - version: 0.3.6 - os-version-recommended: '>=0.2.4' - - os-version-required: '*' - release-notes: | - Bug Fixes - - Upgrade UI to gracefully handle Consulate browser - dependencies: {} - version: 0.3.5 - os-version-recommended: '*' - - os-version-required: '*' - release-notes: | - Bug Fixes - - Register a SIGTERM handler for graceful shutdown - dependencies: {} - version: 0.3.4 - os-version-recommended: '*' - - os-version-required: '*' - release-notes: | - Features - - Conversation manual refresh - Bug Fixes - - Contacts hilighting for unread messages - - Avatar first initial centering - - Styling improvements - dependencies: {} - version: 0.3.3 - os-version-recommended: '*' - - os-version-required: '*' - release-notes: | - Features - - Conversation manual refresh - Bug Fixes - - Contacts hilighting for unread messages - - Avatar first initial centering - - Styling improvements - dependencies: {} - version: 0.3.2 - os-version-recommended: '*' - - os-version-required: '*' - release-notes: | - Big UX overhaul, including the code requisite to power the new Cups Messenger mobile application. - Check out "Cups Messenger" on the iOS and Google Play store - - Usable from your phone without the Tor browser. - - New Dark Theme. - - Message Previews + Old conversation removal - - Fixes bugs from 0.3.0 - dependencies: {} - version: 0.3.1 - os-version-recommended: '*' - - os-version-required: '*' - release-notes: | - Big UX overhaul, including the code requisite to power the new Cups Messenger mobile application. - Check out "Cups Messenger" on the iOS and Google Play store - - Usable from your phone without the Tor browser. - - New Dark Theme. - - Message Previews + Old conversation removal - dependencies: {} - version: 0.3.0 - os-version-recommended: '*' - - os-version-required: '*' - release-notes: Added headers for Consulate caching - dependencies: {} - version: 0.2.4 - os-version-recommended: '*' - - os-version-required: '*' - release-notes: fix autofill for password field - dependencies: {} - version: 0.2.3 - os-version-recommended: '*' - - os-version-required: '*' - release-notes: | - - Massive load-time improvements - dependencies: {} - version: 0.2.2 - os-version-recommended: '*' - - os-version-required: '*' - release-notes: | - - Signin security improvements - dependencies: {} - version: 0.2.1 - os-version-recommended: '*' - - os-version-required: '*' - release-notes: | - # Cups UI released - - Breaks compatibility with cups-cli 0.1.x - dependencies: {} - version: 0.2.0 - os-version-recommended: '*' - - os-version-required: '*' - release-notes: | - # Alpha Release - - Send messages - - Recieve messages - - Contact book - dependencies: {} - version: 0.1.1 - os-version-recommended: '*' - - os-version-required: '*' - release-notes: | - # Alpha Release - - Send messages - - Recieve messages - - Contact book - dependencies: {} - version: 0.1.0 - os-version-recommended: '*' \ No newline at end of file diff --git a/resources/icons/bitcoind.png b/resources/icons/bitcoind.png deleted file mode 100644 index e69de29..0000000 diff --git a/resources/sys/agent/0.0.0/agent b/resources/sys/agent/0.0.0/agent deleted file mode 100644 index e69de29..0000000 diff --git a/resources/sys/appmgr/0.0.0/appmgr b/resources/sys/appmgr/0.0.0/appmgr deleted file mode 100644 index bfad61c..0000000 --- a/resources/sys/appmgr/0.0.0/appmgr +++ /dev/null @@ -1 +0,0 @@ -appmgr downloaded \ No newline at end of file diff --git a/resources/sys/image/0.0.0/image.img.deleteme b/resources/sys/image/0.0.0/image.img.deleteme deleted file mode 100644 index 478ae3e..0000000 --- a/resources/sys/image/0.0.0/image.img.deleteme +++ /dev/null @@ -1 +0,0 @@ -image downloaded \ No newline at end of file diff --git a/resources/sys/proxy.pac/0.1.0/proxy.pac b/resources/sys/proxy.pac/0.1.0/proxy.pac deleted file mode 100644 index e69de29..0000000 diff --git a/resources/sys/sys.tar.gz/1.1.1/sys.tar.gz b/resources/sys/sys.tar.gz/1.1.1/sys.tar.gz deleted file mode 100644 index 32e0202..0000000 --- a/resources/sys/sys.tar.gz/1.1.1/sys.tar.gz +++ /dev/null @@ -1 +0,0 @@ -get it all up down around \ No newline at end of file diff --git a/src/Application.hs b/src/Application.hs index 5a19bbd..ffa7c46 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -24,49 +24,82 @@ module Application , getAppSettings -- * for GHCI , handler + , db ) where -import Startlude hiding (Handler) +import Startlude hiding ( Handler ) -import Control.Monad.Logger (liftLoc, runLoggingT) +import Control.Monad.Logger ( LoggingT + , liftLoc + , runLoggingT + ) import Data.Default -import Database.Persist.Postgresql (createPostgresqlPool, pgConnStr, pgPoolSize, runSqlPool, runMigration) -import Language.Haskell.TH.Syntax (qLocation) +import Database.Persist.Postgresql ( createPostgresqlPool + , pgConnStr + , pgPoolSize + , runMigration + , runSqlPool + ) +import Language.Haskell.TH.Syntax ( qLocation ) import Network.Wai -import Network.Wai.Handler.Warp (Settings, defaultSettings, defaultShouldDisplayException, - getPort, setHost, setOnException, setPort, runSettings, setHTTP2Disabled) +import Network.Wai.Handler.Warp ( Settings + , defaultSettings + , defaultShouldDisplayException + , getPort + , runSettings + , setHTTP2Disabled + , setHost + , setOnException + , setPort + ) import Network.Wai.Handler.WarpTLS import Network.Wai.Middleware.AcceptOverride import Network.Wai.Middleware.Autohead -import Network.Wai.Middleware.Cors (CorsResourcePolicy (..), cors, simpleCorsResourcePolicy) +import Network.Wai.Middleware.Cors ( CorsResourcePolicy(..) + , cors + , simpleCorsResourcePolicy + ) import Network.Wai.Middleware.MethodOverride -import Network.Wai.Middleware.RequestLogger (Destination (Logger), OutputFormat (..), - destination, mkRequestLogger, outputFormat) -import System.IO (hSetBuffering, BufferMode (..)) -import System.Log.FastLogger (defaultBufSize, newStdoutLoggerSet, toLogStr) +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 -import Yesod.Core.Types hiding (Logger) +import Yesod.Core.Types hiding ( Logger ) import Yesod.Default.Config2 --- Import all relevant handler modules here. --- Don't forget to add new modules to your cabal file! +import Control.Arrow ( (***) ) +import Control.Lens +import Data.List ( lookup ) +import Data.String.Interpolate.IsString + ( i ) +import Database.Persist.Sql ( SqlBackend ) import Foundation import Handler.Apps import Handler.ErrorLogs import Handler.Icons -import Handler.Version import Handler.Marketplace +import Handler.Version +import Lib.PkgRepository ( watchPkgRepoRoot ) import Lib.Ssl +import Model +import Network.HTTP.Types.Header ( hOrigin ) +import Network.Wai.Middleware.RequestLogger.JSON import Settings +import System.Directory ( createDirectoryIfMissing ) import System.Posix.Process import System.Time.Extra -import Model -import Control.Lens -import Control.Arrow ((***)) -import Network.HTTP.Types.Header ( hOrigin ) -import Data.List (lookup) -import Network.Wai.Middleware.RequestLogger.JSON -import System.Directory (createDirectoryIfMissing) +import Yesod -- 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 @@ -81,35 +114,36 @@ 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 = 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" + let mkFoundation appConnPool appStopFsNotify = 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 + stop <- runLoggingT (runReaderT watchPkgRepoRoot appSettings) logFunc 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) -- Preform database migration using application logging settings runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc -- Return the foundation - return $ mkFoundation pool + return $ mkFoundation pool stop -- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and -- applying some additional middlewares. @@ -187,14 +221,12 @@ dynamicCorsResourcePolicy req = Just . policy . lookup hOrigin $ requestHeaders } 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 @@ -227,10 +259,10 @@ appMain = do -- Get the settings from all relevant sources settings <- loadYamlSettingsArgs -- fall back to compile-time values, set to [] to require values at runtime - [configSettingsYmlValue] + [configSettingsYmlValue] -- allow environment variables to override - useEnv + useEnv -- Generate the foundation from the settings makeFoundation settings >>= startApp @@ -239,36 +271,38 @@ startApp :: RegistryCtx -> IO () startApp foundation = do when (sslAuto . appSettings $ foundation) $ do -- set up ssl certificates - putStrLn @Text "Setting up SSL" + runLog $ $logInfo "Setting up SSL" _ <- setupSsl $ appSettings foundation - putStrLn @Text "SSL Setup Complete" + runLog $ $logInfo "SSL Setup Complete" -- certbot renew loop void . forkIO $ forever $ flip runReaderT foundation $ do shouldRenew <- doesSslNeedRenew - putStrLn @Text $ "Checking if SSL Certs should be renewed: " <> show shouldRenew + runLog $ $logInfo $ [i|Checking if SSL Certs should be renewed: #{shouldRenew}|] when shouldRenew $ do - putStrLn @Text "Renewing SSL Certs." + 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 = do - let AppSettings{..} = appSettings foundation - putStrLn @Text $ "Launching Tor Web Server on port " <> show torPort + startWeb' app = (`onException` (appStopFsNotify foundation)) $ do + let AppSettings {..} = appSettings foundation + runLog $ $logInfo $ [i|Launching Tor Web Server on port #{torPort}|] torAction <- async $ runSettings (warpSettings torPort foundation) app - putStrLn @Text $ "Launching Web Server on port " <> show appPort + runLog $ $logInfo $ [i|Launching Web Server on port #{appPort}|] action <- if sslAuto - then async $ runTLS (tlsSettings sslCertLocation sslKeyLocation) - (warpSettings appPort foundation) app - else async $ runSettings (warpSettings appPort foundation) app + then async $ runTLS (tlsSettings sslCertLocation sslKeyLocation) (warpSettings appPort foundation) app + else async $ runSettings (warpSettings appPort foundation) app let actions = (action, torAction) setWebProcessThreadId (join (***) asyncThreadId actions) foundation @@ -286,8 +320,9 @@ startWeb foundation = do shouldRestart <- takeMVar (appShouldRestartWeb foundation) when shouldRestart $ do putMVar (appShouldRestartWeb foundation) False - putStrLn @Text "Restarting Web Server" + runLog $ $logInfo "Restarting Web Server" startWeb' app + runLog a = runLoggingT a (messageLoggerSource foundation (appLogger foundation)) restartWeb :: RegistryCtx -> IO () restartWeb foundation = do @@ -301,21 +336,21 @@ shutdownAll threadIds = do -- Careful, you should always spawn this within forkIO so as to avoid accidentally killing the running process shutdownWeb :: RegistryCtx -> IO () -shutdownWeb RegistryCtx{..} = do - threadIds <- takeMVar appWebServerThreadId +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 :: IO (Int, RegistryCtx, Application) getApplicationRepl = do - settings <- getAppSettings + settings <- getAppSettings foundation <- getAppSettings >>= makeFoundation - wsettings <- getDevSettings $ warpSettings (appPort settings) foundation - app1 <- makeApplication foundation - return (getPort wsettings, foundation, app1) + wsettings <- getDevSettings $ warpSettings (appPort settings) foundation + app1 <- makeApplication foundation + return (getPort wsettings, foundation, app1) shutdownApp :: RegistryCtx -> IO () shutdownApp _ = return () @@ -323,10 +358,10 @@ 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 @@ -342,3 +377,7 @@ develMain = do -- | Run a handler handler :: Handler a -> IO a handler h = getAppSettings >>= makeFoundation >>= flip unsafeHandler h + +-- | Run DB queries +db :: ReaderT SqlBackend (HandlerFor RegistryCtx) a -> IO a +db = handler . runDB diff --git a/src/Database/Marketplace.hs b/src/Database/Marketplace.hs index 7bed768..6660dd6 100644 --- a/src/Database/Marketplace.hs +++ b/src/Database/Marketplace.hs @@ -23,7 +23,6 @@ searchServices Nothing pageItems offset' query = select $ do ( (service ^. SAppDescShort `ilike` (%) ++. val query ++. (%)) ||. (service ^. SAppDescLong `ilike` (%) ++. val query ++. (%)) ||. (service ^. SAppTitle `ilike` (%) ++. val query ++. (%)) - ||. (service ^. SAppAppId `ilike` (%) ++. val query ++. (%)) ) orderBy [desc (service ^. SAppUpdatedAt)] limit pageItems @@ -46,7 +45,6 @@ searchServices (Just category) pageItems offset' query = select $ do &&. ( (service ^. SAppDescShort `ilike` (%) ++. val query ++. (%)) ||. (service ^. SAppDescLong `ilike` (%) ++. val query ++. (%)) ||. (service ^. SAppTitle `ilike` (%) ++. val query ++. (%)) - ||. (service ^. SAppAppId `ilike` (%) ++. val query ++. (%)) ) pure service ) diff --git a/src/Database/Queries.hs b/src/Database/Queries.hs index 5fbf2e2..a2decd5 100644 --- a/src/Database/Queries.hs +++ b/src/Database/Queries.hs @@ -4,20 +4,20 @@ module Database.Queries where -import Startlude import Database.Persist.Sql import Lib.Types.AppIndex import Lib.Types.Emver import Model import Orphans.Emver ( ) +import Startlude -fetchApp :: MonadIO m => AppIdentifier -> ReaderT SqlBackend m (Maybe (Entity SApp)) +fetchApp :: MonadIO m => PkgId -> ReaderT SqlBackend m (Maybe (Entity SApp)) fetchApp appId = selectFirst [SAppAppId ==. appId] [] fetchAppVersion :: MonadIO m => Version -> Key SApp -> ReaderT SqlBackend m (Maybe (Entity SVersion)) fetchAppVersion appVersion appId = selectFirst [SVersionNumber ==. appVersion, SVersionAppId ==. appId] [] -createApp :: MonadIO m => AppIdentifier -> StoreApp -> ReaderT SqlBackend m (Maybe (Key SApp)) +createApp :: MonadIO m => PkgId -> StoreApp -> ReaderT SqlBackend m (Maybe (Key SApp)) createApp appId StoreApp {..} = do time <- liftIO getCurrentTime insertUnique $ SApp time Nothing storeAppTitle appId storeAppDescShort storeAppDescLong storeAppIconType diff --git a/src/Foundation.hs b/src/Foundation.hs index 7e7ebad..29632a6 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -2,21 +2,45 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeApplications #-} module Foundation where import Startlude hiding ( Handler ) -import Control.Monad.Logger ( LogSource ) -import Database.Persist.Sql +import Control.Monad.Logger ( Loc + , LogSource + , LogStr + , ToLogStr(toLogStr) + , fromLogStr + ) +import Database.Persist.Sql hiding ( update ) import Lib.Registry import Yesod.Core -import Yesod.Core.Types ( Logger ) +import Yesod.Core.Types ( HandlerData(handlerEnv) + , Logger(loggerDate) + , RunHandlerEnv(rheChild, rheSite) + , loggerPutStr + ) import qualified Yesod.Core.Unsafe as Unsafe +import Control.Monad.Logger.Extras ( wrapSGRCode ) +import Control.Monad.Reader.Has ( Has(extract, update) ) +import Data.String.Interpolate.IsString + ( i ) +import qualified Data.Text as T +import Language.Haskell.TH ( Loc(..) ) +import Lib.PkgRepository import Lib.Types.AppIndex import Settings +import System.Console.ANSI.Codes ( Color(..) + , ColorIntensity(..) + , ConsoleLayer(Foreground) + , SGR(SetColor) + ) +import System.FilePath ( () ) import Yesod.Persist.Core -- | The foundation datatype for your application. This can be a good place to @@ -31,7 +55,24 @@ data RegistryCtx = RegistryCtx , appWebServerThreadId :: MVar (ThreadId, ThreadId) , appShouldRestartWeb :: MVar Bool , appConnPool :: ConnectionPool + , appStopFsNotify :: IO Bool } +instance Has PkgRepo RegistryCtx where + extract = do + liftA2 PkgRepo (( "apps") . resourcesDir . appSettings) (staticBinDir . appSettings) + update f ctx = + let repo = f $ extract ctx + settings = (appSettings ctx) { resourcesDir = pkgRepoFileRoot repo, staticBinDir = pkgRepoAppMgrBin repo } + in ctx { appSettings = settings } +instance Has PkgRepo (HandlerData RegistryCtx RegistryCtx) 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 } + + + setWebProcessThreadId :: (ThreadId, ThreadId) -> RegistryCtx -> IO () setWebProcessThreadId tid a = putMVar (appWebServerThreadId a) $ tid @@ -78,6 +119,42 @@ instance Yesod RegistryCtx where 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 = + toLogStr date + <> ( toLogStr + . 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|] + ) + ) + loggerPutStr logger formatted + where + renderLvl lvl = case lvl of + LevelOther t -> toLogStr t + _ -> toLogStr @String $ drop 5 $ show lvl + colorFor = \case + LevelDebug -> Green + LevelInfo -> Blue + LevelWarn -> Yellow + LevelError -> Red + LevelOther _ -> White + + -- How to run database actions. instance YesodPersist RegistryCtx where type YesodPersistBackend RegistryCtx = SqlBackend diff --git a/src/Handler/Apps.hs b/src/Handler/Apps.hs index 7f8d1ed..7ef0b06 100644 --- a/src/Handler/Apps.hs +++ b/src/Handler/Apps.hs @@ -11,37 +11,58 @@ module Handler.Apps where import Startlude hiding ( Handler ) -import Control.Monad.Logger -import Data.Aeson +import Control.Monad.Logger ( logError + , logInfo + ) +import Data.Aeson ( ToJSON + , encode + ) import qualified Data.Attoparsec.Text as Atto import qualified Data.ByteString.Lazy as BS -import Data.Conduit -import qualified Data.Conduit.Binary as CB import qualified Data.Text as T -import Database.Persist +import Database.Persist ( Entity(entityKey) ) import qualified GHC.Show ( Show(..) ) -import Network.HTTP.Types -import System.Directory +import Network.HTTP.Types ( status404 ) import System.FilePath ( (<.>) - , () + , takeBaseName ) -import System.Posix.Files ( fileSize - , getFileStatus +import Yesod.Core ( TypedContent + , addHeader + , notFound + , respondSource + , sendChunkBS + , sendResponseStatus + , typeJson + , typeOctet + , waiRequest ) -import Yesod.Core -import Yesod.Persist.Core +import Yesod.Persist.Core ( YesodPersist(runDB) ) -import Foundation -import Lib.Registry -import Lib.Types.AppIndex -import Lib.Types.Emver -import Lib.Types.FileSystem -import Lib.Error -import Lib.External.AppMgr -import Settings -import Database.Queries +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 + , parseVersion + ) import Network.Wai ( Request(requestHeaderUserAgent) ) -import Util.Shared +import Util.Shared ( addPackageHeader + , getVersionSpecFromQuery + , orThrow + ) pureLog :: Show a => a -> Handler a pureLog = liftA2 (*>) ($logInfo . show) pure @@ -65,94 +86,42 @@ getEmbassyOsVersion = userAgentOsVersion userAgentOsVersion = (hush . Atto.parseOnly userAgentOsVersionParser . decodeUtf8 <=< requestHeaderUserAgent) <$> waiRequest -getSysR :: Extension "" -> Handler TypedContent -getSysR e = do - sysResourceDir <- ( "sys") . resourcesDir . appSettings <$> getYesod - -- @TODO update with new response type here - getApp sysResourceDir e +getAppManifestR :: PkgId -> Handler TypedContent +getAppManifestR pkg = do + versionSpec <- getVersionSpecFromQuery + version <- getBestVersion pkg versionSpec + `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 -getAppManifestR :: AppIdentifier -> Handler TypedContent -getAppManifestR appId = do - (appsDir, appMgrDir) <- getsYesod $ (( "apps") . resourcesDir &&& staticBinDir) . appSettings - av <- getVersionFromQuery appsDir appExt >>= \case - Nothing -> sendResponseStatus status404 ("Specified App Version Not Found" :: Text) - Just v -> pure v - let appDir = (<> "/") . ( show av) . ( toS appId) $ appsDir - manifest <- handleS9ErrT $ getManifest appMgrDir appDir appExt - addPackageHeader appMgrDir appDir appExt - pure $ TypedContent "application/json" (toContent manifest) - where appExt = Extension (toS appId) :: Extension "s9pk" +getAppR :: S9PK -> Handler TypedContent +getAppR file = do + let pkg = PkgId . T.pack $ takeBaseName (show file) + versionSpec <- getVersionSpecFromQuery + version <- getBestVersion pkg versionSpec + `orThrow` sendResponseStatus status404 (NotFoundE [i|#{pkg} satisfying #{versionSpec}|]) + addPackageHeader pkg version + void $ recordMetrics pkg version + (len, src) <- getPackage pkg version + addHeader "Content-Length" (show len) + respondSource typeOctet $ src .| awaitForever sendChunkBS -getAppConfigR :: AppIdentifier -> Handler TypedContent -getAppConfigR appId = do - appSettings <- appSettings <$> getYesod - let appsDir = ( "apps") . resourcesDir $ appSettings - let appMgrDir = staticBinDir appSettings - av <- getVersionFromQuery appsDir appExt >>= \case - Nothing -> sendResponseStatus status404 ("Specified App Version Not Found" :: Text) - Just v -> pure v - let appDir = (<> "/") . ( show av) . ( toS appId) $ appsDir - config <- handleS9ErrT $ getConfig appMgrDir appDir appExt - addPackageHeader appMgrDir appDir appExt - pure $ TypedContent "application/json" (toContent config) - where appExt = Extension (toS appId) :: Extension "s9pk" -getAppR :: Extension "s9pk" -> Handler TypedContent -getAppR e = do - appResourceDir <- ( "apps") . resourcesDir . appSettings <$> getYesod - getApp appResourceDir e - -getApp :: KnownSymbol a => FilePath -> Extension a -> Handler TypedContent -getApp rootDir ext@(Extension appId) = do - specString <- T.filter (not . isSpace) . fromMaybe "*" <$> lookupGetParam "spec" - spec <- case readMaybe specString of - Nothing -> sendResponseStatus status400 ("Invalid App Version Specification" :: Text) - Just t -> pure t - appVersions <- liftIO $ getAvailableAppVersions rootDir ext - putStrLn $ "valid appversion for " <> (show ext :: String) <> ": " <> show appVersions - let satisfactory = filter ((<|| spec) . fst . unRegisteredAppVersion) appVersions - let best = fst . getMaxVersion <$> foldMap (Just . MaxVersion . (, fst . unRegisteredAppVersion)) satisfactory - (appsDir, appMgrDir) <- getsYesod $ (( "apps") . resourcesDir &&& staticBinDir) . appSettings - case best of - Nothing -> notFound - Just (RegisteredAppVersion (appVersion, filePath)) -> do - exists' <- liftIO $ doesFileExist filePath >>= \case - True -> pure Existent - False -> pure NonExistent - let appDir = (<> "/") . ( show appVersion) . ( toS appId) $ appsDir - let appExt = Extension (toS appId) :: Extension "s9pk" - addPackageHeader appMgrDir appDir appExt - determineEvent exists' (extension ext) filePath appVersion - where - determineEvent :: FileExistence -> String -> FilePath -> Version -> HandlerFor RegistryCtx TypedContent - -- for app files - determineEvent Existent "s9pk" fp av = do - _ <- recordMetrics appId av - chunkIt fp - -- for png, system, etc - determineEvent Existent _ fp _ = chunkIt fp - determineEvent NonExistent _ _ _ = notFound - -chunkIt :: FilePath -> HandlerFor RegistryCtx TypedContent -chunkIt fp = do - sz <- liftIO $ fileSize <$> getFileStatus fp - addHeader "Content-Length" (show sz) - respondSource typeOctet $ CB.sourceFile fp .| awaitForever sendChunkBS - -recordMetrics :: String -> Version -> HandlerFor RegistryCtx () -recordMetrics appId appVersion = do - let appId' = T.pack appId - sa <- runDB $ fetchApp appId' +recordMetrics :: PkgId -> Version -> Handler () +recordMetrics pkg appVersion = do + sa <- runDB $ fetchApp $ pkg case sa of Nothing -> do - $logError $ appId' <> " not found in database" + $logError $ [i|#{pkg} not found in database|] notFound Just a -> do let appKey' = entityKey a existingVersion <- runDB $ fetchAppVersion appVersion appKey' case existingVersion of Nothing -> do - $logError $ "Version: " <> show appVersion <> " not found in database" + $logError $ [i|#{pkg}@#{appVersion} not found in database|] notFound Just v -> runDB $ createMetric (entityKey a) (entityKey v) diff --git a/src/Handler/Icons.hs b/src/Handler/Icons.hs index 7dadaba..6333bd7 100644 --- a/src/Handler/Icons.hs +++ b/src/Handler/Icons.hs @@ -2,6 +2,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -9,19 +10,22 @@ module Handler.Icons where import Startlude hiding ( Handler ) -import Yesod.Core - -import Data.Aeson -import qualified Data.ByteString.Lazy as BS +import Data.Conduit ( (.|) + , awaitForever + ) +import Data.String.Interpolate.IsString + ( i ) import Foundation -import Lib.Error -import Lib.External.AppMgr -import Lib.Registry +import Lib.Error ( S9Error(NotFoundE) ) +import Lib.PkgRepository ( getBestVersion + , getIcon + , getInstructions + , getLicense + ) import Lib.Types.AppIndex import Network.HTTP.Types -import Settings -import System.FilePath.Posix import Util.Shared +import Yesod.Core data IconType = PNG | JPG | JPEG | SVG deriving (Eq, Show, Generic, Read) @@ -33,62 +37,29 @@ instance FromJSON IconType ixt :: Text ixt = toS $ toUpper <$> drop 1 ".png" -getIconsR :: AppIdentifier -> Handler TypedContent -getIconsR appId = do - (appsDir, appMgrDir) <- getsYesod $ (( "apps") . resourcesDir &&& staticBinDir) . appSettings - spec <- getVersionFromQuery appsDir ext >>= \case - Nothing -> sendResponseStatus status404 ("Specified App Version Not Found" :: Text) - Just v -> pure v - let appDir = (<> "/") . ( show spec) . ( toS appId) $ appsDir - manifest' <- handleS9ErrT $ getManifest appMgrDir appDir ext - manifest <- case eitherDecode $ BS.fromStrict manifest' of - Left e -> do - $logError "could not parse service manifest!" - $logError (show e) - sendResponseStatus status500 ("Internal Server Error" :: Text) - Right a -> pure a - mimeType <- case serviceManifestIcon manifest of - Nothing -> pure typePng - Just a -> do - let (_, iconExt) = splitExtension $ toS a - let x = toUpper <$> drop 1 iconExt - case readMaybe $ toS x of - Nothing -> do - $logInfo $ "unknown icon extension type: " <> show x <> ". Sending back typePlain." - pure typePlain - Just iconType -> case iconType of - PNG -> pure typePng - SVG -> pure typeSvg - JPG -> pure typeJpeg - JPEG -> pure typeJpeg - respondSource mimeType (sendChunkBS =<< handleS9ErrT (getIcon appMgrDir (appDir show ext) ext)) - -- (_, Just hout, _, _) <- liftIO (createProcess $ iconBs { std_out = CreatePipe }) - -- respondSource typePlain (runConduit $ yieldMany () [iconBs]) - -- respondSource typePlain $ sourceHandle hout .| awaitForever sendChunkBS - where ext = Extension (toS appId) :: Extension "s9pk" +getIconsR :: PkgId -> Handler TypedContent +getIconsR pkg = do + spec <- getVersionSpecFromQuery + version <- getBestVersion pkg spec + `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 :: AppIdentifier -> Handler TypedContent -getLicenseR appId = do - (appsDir, appMgrDir) <- getsYesod $ (( "apps") . resourcesDir &&& staticBinDir) . appSettings - spec <- getVersionFromQuery appsDir ext >>= \case - Nothing -> sendResponseStatus status404 ("Specified App Version Not Found" :: Text) - Just v -> pure v - servicePath <- liftIO $ getVersionedFileFromDir appsDir ext spec - case servicePath of - Nothing -> notFound - Just p -> do - respondSource typePlain (sendChunkBS =<< handleS9ErrT (getLicense appMgrDir p ext)) - where ext = Extension (toS appId) :: Extension "s9pk" +getLicenseR :: PkgId -> Handler TypedContent +getLicenseR pkg = do + spec <- getVersionSpecFromQuery + version <- getBestVersion pkg spec + `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 :: AppIdentifier -> Handler TypedContent -getInstructionsR appId = do - (appsDir, appMgrDir) <- getsYesod $ (( "apps") . resourcesDir &&& staticBinDir) . appSettings - spec <- getVersionFromQuery appsDir ext >>= \case - Nothing -> sendResponseStatus status404 ("Specified App Version Not Found" :: Text) - Just v -> pure v - servicePath <- liftIO $ getVersionedFileFromDir appsDir ext spec - case servicePath of - Nothing -> notFound - Just p -> do - respondSource typePlain (sendChunkBS =<< handleS9ErrT (getInstructions appMgrDir p ext)) - where ext = Extension (toS appId) :: Extension "s9pk" +getInstructionsR :: PkgId -> Handler TypedContent +getInstructionsR pkg = do + spec <- getVersionSpecFromQuery + version <- getBestVersion pkg spec + `orThrow` sendResponseStatus status400 (NotFoundE [i|Instructions for #{pkg} satisfying #{spec}|]) + (len, src) <- getInstructions pkg version + addHeader "Content-Length" (show len) + respondSource typePlain $ src .| awaitForever sendChunkBS diff --git a/src/Handler/Marketplace.hs b/src/Handler/Marketplace.hs index 46f0968..f1df3e2 100644 --- a/src/Handler/Marketplace.hs +++ b/src/Handler/Marketplace.hs @@ -7,39 +7,135 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TupleSections #-} - +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveAnyClass #-} module Handler.Marketplace where -import Startlude hiding ( from - , Handler + +import Startlude hiding ( Handler + , from , on , sortOn ) -import Foundation -import Yesod.Core -import qualified Database.Persist as P -import Model -import Yesod.Persist.Core -import Database.Marketplace -import Data.List -import Lib.Types.Category -import Lib.Types.AppIndex -import qualified Data.HashMap.Strict as HM -import Lib.Types.Emver -import qualified Data.List.NonEmpty as NE -import Database.Esqueleto.Experimental -import Lib.Error -import Network.HTTP.Types -import Lib.Registry -import Settings -import System.FilePath.Posix -import Lib.External.AppMgr -import Data.Aeson -import qualified Data.ByteString.Lazy as BS -import qualified Data.Text as T -import Data.String.Interpolate.IsString -import Util.Shared +import Conduit ( (.|) + , awaitForever + , runConduit + , sourceFile + ) +import Control.Monad.Except.CoHas ( liftEither ) +import Control.Parallel.Strategies ( parMap + , rpar + ) +import Data.Aeson ( (.:) + , FromJSON(parseJSON) + , KeyValue((.=)) + , ToJSON(toJSON) + , Value(String) + , decode + , eitherDecode + , eitherDecodeStrict + , object + , withObject + ) +import qualified Data.Attoparsec.Text as Atto +import qualified Data.ByteString.Lazy as BS +import qualified Data.Conduit.List as CL +import qualified Data.HashMap.Strict as HM +import Data.List ( head + , lookup + , sortOn + ) +import Data.Semigroup ( Max(Max, getMax) ) +import Data.String.Interpolate.IsString + ( i ) +import qualified Data.Text as T +import Database.Esqueleto.Experimental + ( (&&.) + , (:&)((:&)) + , (==.) + , (?.) + , Entity(entityKey, entityVal) + , PersistEntity(Key) + , SqlBackend + , Value(unValue) + , (^.) + , desc + , from + , groupBy + , innerJoin + , just + , leftJoin + , limit + , on + , orderBy + , select + , selectOne + , table + , val + , where_ + ) +import Database.Esqueleto.PostgreSQL ( arrayAggDistinct ) +import Database.Marketplace ( searchServices ) +import qualified Database.Persist as P +import Foundation ( Handler + , RegistryCtx(appSettings) + ) +import Lib.Error ( S9Error(..) ) +import Lib.PkgRepository ( getManifest ) +import Lib.Types.AppIndex ( PkgId(PkgId) + , ServiceDependencyInfo(serviceDependencyInfoVersion) + , ServiceManifest(serviceManifestDependencies) + , VersionInfo(..) + ) +import Lib.Types.AppIndex ( ) +import Lib.Types.Category ( CategoryTitle(FEATURED) ) +import Lib.Types.Emver ( (<||) + , Version + , VersionRange + , parseVersion + , satisfies + ) +import Model ( Category(..) + , EntityField(..) + , OsVersion(..) + , SApp(..) + , SVersion(..) + , ServiceCategory + ) +import Network.HTTP.Types ( status400 + , status404 + ) +import Protolude.Unsafe ( unsafeFromJust ) +import Settings ( AppSettings(registryHostname, resourcesDir) ) +import System.FilePath ( () ) +import UnliftIO.Async ( concurrently + , mapConcurrently + ) +import UnliftIO.Directory ( listDirectory ) +import Util.Shared ( getVersionSpecFromQuery + , orThrow + ) +import Yesod.Core ( HandlerFor + , MonadLogger + , MonadResource + , MonadUnliftIO + , ToContent(..) + , ToTypedContent(..) + , TypedContent + , YesodRequest(..) + , getRequest + , getsYesod + , logWarn + , lookupGetParam + , respondSource + , sendChunkBS + , sendResponseStatus + , typeOctet + ) +import Yesod.Persist.Core ( YesodPersist(runDB) ) + +type URL = Text newtype CategoryRes = CategoryRes { categories :: [CategoryTitle] } deriving (Show, Generic) @@ -49,15 +145,16 @@ instance ToContent CategoryRes where toContent = toContent . toJSON instance ToTypedContent CategoryRes where toTypedContent = toTypedContent . toJSON -data ServiceRes = ServiceRes - { serviceResIcon :: URL - , serviceResManifest :: Maybe Data.Aeson.Value -- ServiceManifest - , serviceResCategories :: [CategoryTitle] - , serviceResInstructions :: URL - , serviceResLicense :: URL - , serviceResVersions :: [Version] - , serviceResDependencyInfo :: HM.HashMap AppIdentifier DependencyInfo - } deriving (Generic) +data ServiceRes = ServiceRes + { serviceResIcon :: URL + , serviceResManifest :: Data.Aeson.Value -- ServiceManifest + , serviceResCategories :: [CategoryTitle] + , serviceResInstructions :: URL + , serviceResLicense :: URL + , serviceResVersions :: [Version] + , serviceResDependencyInfo :: HM.HashMap PkgId DependencyInfo + } + deriving Generic newtype ReleaseNotes = ReleaseNotes { unReleaseNotes :: HM.HashMap Version Text } deriving (Eq, Show) @@ -82,16 +179,18 @@ instance ToContent ServiceRes where instance ToTypedContent ServiceRes where toTypedContent = toTypedContent . toJSON data DependencyInfo = DependencyInfo - { dependencyInfoTitle :: Text -- title - , dependencyInfoIcon :: Text -- url - } deriving (Eq, Show) + { dependencyInfoTitle :: PkgId + , dependencyInfoIcon :: URL + } + deriving (Eq, Show) instance ToJSON DependencyInfo where toJSON DependencyInfo {..} = object ["icon" .= dependencyInfoIcon, "title" .= dependencyInfoTitle] -data ServiceListRes = ServiceListRes { - serviceListResCategories :: [CategoryTitle] - , serviceListResServices :: [ServiceAvailable] -} deriving (Show) +data ServiceListRes = ServiceListRes + { serviceListResCategories :: [CategoryTitle] + , serviceListResServices :: [ServiceAvailable] + } + deriving Show instance ToJSON ServiceListRes where toJSON ServiceListRes {..} = object ["categories" .= serviceListResCategories, "services" .= serviceListResServices] @@ -101,12 +200,13 @@ instance ToTypedContent ServiceListRes where toTypedContent = toTypedContent . toJSON data ServiceAvailable = ServiceAvailable - { serviceAvailableId :: Text - , serviceAvailableTitle :: Text - , serviceAvailableVersion :: Version - , serviceAvailableIcon :: URL + { serviceAvailableId :: PkgId + , serviceAvailableTitle :: Text + , serviceAvailableVersion :: Version + , serviceAvailableIcon :: URL , serviceAvailableDescShort :: Text - } deriving (Show) + } + deriving Show instance ToJSON ServiceAvailable where toJSON ServiceAvailable {..} = object [ "id" .= serviceAvailableId @@ -128,7 +228,7 @@ instance ToContent ServiceAvailableRes where instance ToTypedContent ServiceAvailableRes where toTypedContent = toTypedContent . toJSON -newtype VersionLatestRes = VersionLatestRes (HM.HashMap AppIdentifier (Maybe Version)) +newtype VersionLatestRes = VersionLatestRes (HM.HashMap PkgId (Maybe Version)) deriving (Show, Generic) instance ToJSON VersionLatestRes instance ToContent VersionLatestRes where @@ -138,18 +238,19 @@ instance ToTypedContent VersionLatestRes where data OrderArrangement = ASC | DESC deriving (Eq, Show, Read) data ServiceListDefaults = ServiceListDefaults - { serviceListOrder :: OrderArrangement - , serviceListPageLimit :: Int64 -- the number of items per page + { serviceListOrder :: OrderArrangement + , serviceListPageLimit :: Int64 -- the number of items per page , serviceListPageNumber :: Int64 -- the page you are on - , serviceListCategory :: Maybe CategoryTitle - , serviceListQuery :: Text + , serviceListCategory :: Maybe CategoryTitle + , serviceListQuery :: Text } deriving (Eq, Show, Read) data EosRes = EosRes - { eosResVersion :: Version - , eosResHeadline :: Text + { eosResVersion :: Version + , eosResHeadline :: Text , eosResReleaseNotes :: ReleaseNotes -} deriving (Eq, Show, Generic) + } + deriving (Eq, Show, Generic) instance ToJSON EosRes where toJSON EosRes {..} = object ["version" .= eosResVersion, "headline" .= eosResHeadline, "release-notes" .= eosResReleaseNotes] @@ -159,9 +260,10 @@ instance ToTypedContent EosRes where toTypedContent = toTypedContent . toJSON data PackageVersion = PackageVersion - { packageVersionId :: AppIdentifier + { packageVersionId :: PkgId , packageVersionVersion :: VersionRange - } deriving (Show) + } + deriving Show instance FromJSON PackageVersion where parseJSON = withObject "package version" $ \o -> do packageVersionId <- o .: "id" @@ -176,8 +278,8 @@ getCategoriesR = do pure cats pure $ CategoryRes $ categoryName . entityVal <$> allCategories -getEosR :: Handler EosRes -getEosR = do +getEosVersionR :: Handler EosRes +getEosVersionR = do allEosVersions <- runDB $ select $ do vers <- from $ table @OsVersion orderBy [desc (vers ^. OsVersionCreatedAt)] @@ -199,159 +301,188 @@ getReleaseNotesR :: Handler ReleaseNotes getReleaseNotesR = do getParameters <- reqGetParams <$> getRequest case lookup "id" getParameters of - Nothing -> sendResponseStatus status400 ("expected query param \"id\" to exist" :: Text) + Nothing -> sendResponseStatus status400 (InvalidParamsE "get:id" "") Just package -> do - (service, _ ) <- runDB $ fetchLatestApp package >>= errOnNothing status404 "package not found" - (_ , mappedVersions) <- fetchAllAppVersions (entityKey service) + (service, _) <- runDB $ fetchLatestApp (PkgId package) `orThrow` sendResponseStatus + status404 + (NotFoundE $ show package) + (_, mappedVersions) <- fetchAllAppVersions (entityKey service) pure mappedVersions +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 res = headMay . sortOn Down . filter (`satisfies` spec) $ successes + case res of + Nothing -> sendResponseStatus status404 (NotFoundE [i|EOS version satisfying #{spec}|]) + Just r -> do + let imgPath = root show r "eos.img" + respondSource typeOctet (sourceFile imgPath .| awaitForever sendChunkBS) + getVersionLatestR :: Handler VersionLatestRes getVersionLatestR = do getParameters <- reqGetParams <$> getRequest case lookup "ids" getParameters of - Nothing -> sendResponseStatus status400 ("expected query param \"ids\" to exist" :: Text) + Nothing -> sendResponseStatus status400 (InvalidParamsE "get:ids" "") Just packages -> case eitherDecode $ BS.fromStrict $ encodeUtf8 packages of - Left e -> sendResponseStatus status400 ("could not parse query param \"ids\"" <> show e :: Text) - Right (p :: [AppIdentifier]) -> do - let packageList :: [(AppIdentifier, Maybe Version)] = (, Nothing) <$> p + Left _ -> sendResponseStatus status400 (InvalidParamsE "get:ids" packages) + Right (p :: [PkgId]) -> do + let packageList :: [(PkgId, Maybe Version)] = (, Nothing) <$> p found <- runDB $ traverse fetchLatestApp $ fst <$> packageList pure $ VersionLatestRes $ HM.union ( HM.fromList - $ (\v -> - ( sAppAppId $ entityVal $ fst v :: AppIdentifier - , Just $ sVersionNumber $ entityVal $ snd v - ) - ) + $ (\v -> (sAppAppId $ entityVal $ fst v, Just $ sVersionNumber $ entityVal $ snd v)) <$> catMaybes found ) $ HM.fromList packageList getPackageListR :: Handler ServiceAvailableRes getPackageListR = do - getParameters <- reqGetParams <$> getRequest - let defaults = ServiceListDefaults { serviceListOrder = DESC + pkgIds <- getPkgIdsQuery + case pkgIds of + Nothing -> do + -- query for all + category <- getCategoryQuery + page <- getPageQuery + limit' <- getLimitQuery + query <- T.strip . fromMaybe (serviceListQuery defaults) <$> lookupGetParam "query" + filteredServices <- runDB $ searchServices category limit' ((page - 1) * limit') query + let filteredServices' = sAppAppId . entityVal <$> filteredServices + settings <- getsYesod appSettings + packageMetadata <- runDB $ fetchPackageMetadata + serviceDetailResult <- mapConcurrently (getServiceDetails settings packageMetadata Nothing) + filteredServices' + let (_, services) = partitionEithers serviceDetailResult + pure $ ServiceAvailableRes services + + Just packages -> do + -- for each item in list get best available from version range + settings <- getsYesod appSettings + -- @TODO fix _ error + packageMetadata <- runDB $ fetchPackageMetadata + availableServicesResult <- traverse (getPackageDetails packageMetadata) packages + let (_, availableServices) = partitionEithers availableServicesResult + serviceDetailResult <- mapConcurrently (uncurry $ getServiceDetails settings packageMetadata) + availableServices + -- @TODO fix _ error + let (_, services) = partitionEithers serviceDetailResult + pure $ ServiceAvailableRes services + where + defaults = ServiceListDefaults { serviceListOrder = DESC , serviceListPageLimit = 20 , serviceListPageNumber = 1 , serviceListCategory = Nothing , serviceListQuery = "" } - case lookup "ids" getParameters of - Nothing -> do - -- query for all - category <- case lookup "category" getParameters of - Nothing -> pure $ serviceListCategory defaults - Just c -> case readMaybe $ T.toUpper c of - Nothing -> do - $logInfo c - sendResponseStatus status400 ("could not read category" :: Text) - Just t -> pure $ Just t - page <- case lookup "page" getParameters of - Nothing -> pure $ serviceListPageNumber defaults - Just p -> case readMaybe p of - Nothing -> do - $logInfo p - sendResponseStatus status400 ("could not read page" :: Text) - Just t -> pure $ case t of - 0 -> 1 -- disallow page 0 so offset is not negative - _ -> t - limit' <- case lookup "per-page" getParameters of - Nothing -> pure $ serviceListPageLimit defaults - Just c -> case readMaybe $ toS c of - Nothing -> sendResponseStatus status400 ("could not read per-page" :: Text) - Just l -> pure l - query <- T.filter (not . isSpace) . fromMaybe (serviceListQuery defaults) <$> lookupGetParam "query" - filteredServices <- runDB $ searchServices category limit' ((page - 1) * limit') query - -- domain <- getsYesod $ registryHostname . appSettings - -- (appsDir, appMgrDir) <- getsYesod $ (( "apps") . resourcesDir &&& staticBinDir) . appSettings - -- res <- runDB $ traverse (mapEntityToServiceAvailable appMgrDir appsDir domain) filteredServices - res <- traverse (getServiceDetails Nothing) filteredServices - pure $ ServiceAvailableRes res - - Just packageVersionList -> case eitherDecode $ BS.fromStrict $ encodeUtf8 packageVersionList of - Left e -> sendResponseStatus status400 ("could not parse query param \"ids\"" <> show e :: Text) - Right (packages :: [PackageVersion]) -> do - -- for each item in list get best available from version range - availableServices <- traverse getPackageDetails packages - services <- traverse (uncurry getServiceDetails) availableServices - pure $ ServiceAvailableRes services - where - getPackageDetails :: PackageVersion -> HandlerFor RegistryCtx (Maybe (Entity SVersion), Entity SApp) - getPackageDetails pv = do - appsDir <- getsYesod $ (( "apps") . resourcesDir) . appSettings - let appId = packageVersionId pv - let spec = packageVersionVersion pv - let appExt = Extension (toS appId) :: Extension "s9pk" - getBestVersion appsDir appExt spec >>= \case - Nothing -> sendResponseStatus - status404 - ("best version could not be found for " <> appId <> " with spec " <> show spec :: Text) - Just v -> do - (service, version) <- runDB $ fetchLatestAppAtVersion appId v >>= errOnNothing - status404 - ("service at version " <> show v <> " not found") - pure (Just version, service) - -getServiceR :: Handler ServiceRes -getServiceR = do - getParameters <- reqGetParams <$> getRequest - (service, version) <- case lookup "id" getParameters of - Nothing -> sendResponseStatus status404 ("id param should exist" :: Text) - Just appId' -> do - case lookup "version" getParameters of - -- default to latest - @TODO need to determine best available based on OS version? - Nothing -> runDB $ fetchLatestApp appId' >>= errOnNothing status404 "service not found" + getPkgIdsQuery :: Handler (Maybe [PackageVersion]) + 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 Int64 + getPageQuery = lookupGetParam "page" >>= \case + Nothing -> pure $ serviceListPageNumber 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 Int64 + getLimitQuery = lookupGetParam "per-page" >>= \case + Nothing -> pure $ serviceListPageLimit 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 + getPackageDetails :: MonadIO m + => (HM.HashMap PkgId ([Version], [CategoryTitle])) + -> PackageVersion + -> m (Either Text ((Maybe Version), PkgId)) + getPackageDetails metadata pv = do + let appId = packageVersionId pv + let spec = packageVersionVersion pv + pacakgeMetadata <- case HM.lookup appId metadata of + Nothing -> throwIO $ NotFoundE [i|dependency metadata for #{appId} not found.|] + Just m -> pure m + -- get best version from VersionRange of dependency + let satisfactory = filter (<|| spec) (fst pacakgeMetadata) + let best = getMax <$> foldMap (Just . Max) satisfactory + case best of + Nothing -> pure $ Left $ [i|Best version could not be found for #{appId} with spec #{spec}|] Just v -> do - case readMaybe v of - Nothing -> sendResponseStatus status400 ("Invalid App Version Specification" :: Text) - Just vv -> runDB $ fetchLatestAppAtVersion appId' vv >>= errOnNothing - status404 - ("service at version " <> show v <> " not found") - getServiceDetails (Just version) service + pure $ Right (Just v, appId) -getServiceDetails :: Maybe (Entity SVersion) -> Entity SApp -> HandlerFor RegistryCtx ServiceRes -getServiceDetails maybeVersion service = do - (versions, _) <- fetchAllAppVersions (entityKey service) - categories <- runDB $ fetchAppCategories (entityKey service) - (appsDir, appMgrDir) <- getsYesod $ (( "apps") . resourcesDir &&& staticBinDir) . appSettings - domain <- getsYesod $ registryHostname . appSettings - let appId = sAppAppId $ entityVal service +getServiceDetails :: (MonadIO m, MonadResource m) + => AppSettings + -> (HM.HashMap PkgId ([Version], [CategoryTitle])) + -> Maybe Version + -> PkgId + -> m (Either S9Error ServiceRes) +getServiceDetails settings metadata maybeVersion pkg = runExceptT $ do + packageMetadata <- case HM.lookup pkg metadata of + Nothing -> liftEither . Left $ NotFoundE [i|#{pkg} not found.|] + Just m -> pure m + let domain = registryHostname settings version <- case maybeVersion of Nothing -> do - (_, version) <- runDB $ fetchLatestApp appId >>= errOnNothing status404 "service not found" - pure $ sVersionNumber $ entityVal version - Just v -> pure $ sVersionNumber $ entityVal v - let appDir = (<> "/") . ( show version) . ( toS appId) $ appsDir - let appExt = Extension (toS appId) :: Extension "s9pk" - manifest' <- handleS9ErrT $ getManifest appMgrDir appDir appExt - manifest <- case eitherDecode $ BS.fromStrict manifest' of - Left e -> do - $logError "could not parse service manifest!" - $logError (show e) - sendResponseStatus status500 ("Internal Server Error" :: Text) - Right a -> pure a - d <- traverse (mapDependencyMetadata appsDir domain) (HM.toList $ serviceManifestDependencies manifest) - pure $ ServiceRes { serviceResIcon = [i|https://#{domain}/package/icon/#{appId}|] - , serviceResManifest = decode $ BS.fromStrict manifest' -- pass through raw JSON Value - , serviceResCategories = serviceCategoryCategoryName . entityVal <$> categories - , serviceResInstructions = [i|https://#{domain}/package/instructions/#{appId}|] - , serviceResLicense = [i|https://#{domain}/package/license/#{appId}|] - , serviceResVersions = versionInfoVersion <$> versions - , serviceResDependencyInfo = HM.fromList d - } + -- grab first value, which will be the latest version + case fst packageMetadata of + [] -> liftEither . Left $ NotFoundE $ [i|No latest version found for #{pkg}|] + x : _ -> pure x + Just v -> pure v + manifest <- flip runReaderT settings $ (snd <$> getManifest pkg version) >>= \bs -> + runConduit $ bs .| CL.foldMap BS.fromStrict + case eitherDecode manifest of + Left _ -> liftEither . Left $ AssetParseE [i|#{pkg}:manifest|] (decodeUtf8 $ BS.toStrict manifest) + Right m -> do + let d = parMap rpar (mapDependencyMetadata domain metadata) (HM.toList $ serviceManifestDependencies m) + pure $ ServiceRes { serviceResIcon = [i|https://#{domain}/package/icon/#{pkg}|] + -- pass through raw JSON Value, we have checked its correct parsing above + , serviceResManifest = unsafeFromJust . decode $ manifest + , serviceResCategories = snd packageMetadata + , serviceResInstructions = [i|https://#{domain}/package/instructions/#{pkg}|] + , serviceResLicense = [i|https://#{domain}/package/license/#{pkg}|] + , serviceResVersions = fst packageMetadata + , serviceResDependencyInfo = HM.fromList $ snd $ partitionEithers d + } -type URL = Text -mapDependencyMetadata :: (MonadIO m, MonadHandler m) - => FilePath - -> Text - -> (AppIdentifier, ServiceDependencyInfo) - -> m (AppIdentifier, DependencyInfo) -mapDependencyMetadata appsDir domain (appId, depInfo) = do - let ext = (Extension (toS appId) :: Extension "s9pk") +mapDependencyMetadata :: Text + -> HM.HashMap PkgId ([Version], [CategoryTitle]) + -> (PkgId, ServiceDependencyInfo) + -> Either S9Error (PkgId, DependencyInfo) +mapDependencyMetadata domain metadata (appId, depInfo) = do + depMetadata <- case HM.lookup appId metadata of + Nothing -> Left $ NotFoundE [i|dependency metadata for #{appId} not found.|] + Just m -> pure m -- get best version from VersionRange of dependency - version <- getBestVersion appsDir ext (serviceDependencyInfoVersion depInfo) >>= \case - Nothing -> sendResponseStatus status404 ("best version not found for dependent package " <> appId :: Text) + let satisfactory = filter (<|| serviceDependencyInfoVersion depInfo) (fst depMetadata) + let best = getMax <$> foldMap (Just . Max) satisfactory + version <- case best of + Nothing -> Left $ NotFoundE $ [i|No satisfactory version for dependent package #{appId}|] Just v -> pure v pure ( appId @@ -360,24 +491,7 @@ mapDependencyMetadata appsDir domain (appId, depInfo) = do } ) -decodeIcon :: (MonadHandler m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> m URL -decodeIcon appmgrPath depPath e@(Extension icon) = do - icon' <- handleS9ErrT $ getIcon appmgrPath depPath e - case eitherDecode $ BS.fromStrict icon' of - Left e' -> do - $logInfo $ T.pack e' - sendResponseStatus status400 e' - Right (i' :: URL) -> pure $ i' <> T.pack icon -decodeInstructions :: (MonadHandler m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> m Text -decodeInstructions appmgrPath depPath package = do - instructions <- handleS9ErrT $ getInstructions appmgrPath depPath package - pure $ decodeUtf8 instructions - -decodeLicense :: (MonadHandler m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> m Text -decodeLicense appmgrPath depPath package = do - license <- handleS9ErrT $ getLicense appmgrPath depPath package - pure $ decodeUtf8 license fetchAllAppVersions :: Key SApp -> HandlerFor RegistryCtx ([VersionInfo], ReleaseNotes) fetchAllAppVersions appId = do @@ -386,6 +500,18 @@ fetchAllAppVersions appId = do let vv = mapSVersionToVersionInfo vers let mappedVersions = ReleaseNotes $ HM.fromList $ (\v -> (versionInfoVersion v, versionInfoReleaseNotes v)) <$> vv pure (vv, mappedVersions) + where + mapSVersionToVersionInfo :: [SVersion] -> [VersionInfo] + mapSVersionToVersionInfo sv = do + (\v -> VersionInfo { versionInfoVersion = sVersionNumber v + , versionInfoReleaseNotes = sVersionReleaseNotes v + , versionInfoDependencies = HM.empty + , versionInfoOsRequired = sVersionOsVersionRequired v + , versionInfoOsRecommended = sVersionOsVersionRecommended v + , versionInfoInstallAlert = Nothing + } + ) + <$> sv fetchMostRecentAppVersions :: MonadIO m => Key SApp -> ReaderT SqlBackend m [Entity SVersion] fetchMostRecentAppVersions appId = select $ do @@ -395,7 +521,7 @@ fetchMostRecentAppVersions appId = select $ do limit 1 pure version -fetchLatestApp :: MonadIO m => Text -> ReaderT SqlBackend m (Maybe (P.Entity SApp, P.Entity SVersion)) +fetchLatestApp :: MonadIO m => PkgId -> ReaderT SqlBackend m (Maybe (P.Entity SApp, P.Entity SVersion)) fetchLatestApp appId = selectOne $ do (service :& version) <- from @@ -407,7 +533,7 @@ fetchLatestApp appId = selectOne $ do pure (service, version) fetchLatestAppAtVersion :: MonadIO m - => Text + => PkgId -> Version -> ReaderT SqlBackend m (Maybe (P.Entity SApp, P.Entity SVersion)) fetchLatestAppAtVersion appId version' = selectOne $ do @@ -419,6 +545,38 @@ fetchLatestAppAtVersion appId version' = selectOne $ do where_ $ (service ^. SAppAppId ==. val appId) &&. (version ^. SVersionNumber ==. val version') pure (service, version) +fetchPackageMetadata :: (MonadLogger m, MonadUnliftIO m) + => ReaderT SqlBackend m (HM.HashMap PkgId ([Version], [CategoryTitle])) +fetchPackageMetadata = do + let categoriesQuery = select $ do + (service :& category) <- + from + $ table @SApp + `leftJoin` table @ServiceCategory + `on` (\(service :& category) -> + Database.Esqueleto.Experimental.just (service ^. SAppId) + ==. category + ?. ServiceCategoryServiceId + ) + Database.Esqueleto.Experimental.groupBy $ service ^. SAppAppId + pure (service ^. SAppAppId, arrayAggDistinct (category ?. ServiceCategoryCategoryName)) + let versionsQuery = select $ do + (service :& version) <- + from + $ table @SApp + `innerJoin` table @SVersion + `on` (\(service :& version) -> (service ^. SAppId) ==. version ^. SVersionAppId) + orderBy [desc (version ^. SVersionNumber)] + Database.Esqueleto.Experimental.groupBy $ (service ^. SAppAppId, version ^. SVersionNumber) + pure (service ^. SAppAppId, arrayAggDistinct (version ^. SVersionNumber)) + (categories, versions) <- UnliftIO.Async.concurrently categoriesQuery versionsQuery + let + c = foreach categories + $ \(appId, categories') -> (unValue appId, catMaybes $ fromMaybe [] (unValue categories')) + let v = foreach versions $ \(appId, versions') -> (unValue appId, fromMaybe [] (unValue versions')) + let vv = HM.fromListWithKey (\_ vers vers' -> (++) vers vers') v + pure $ HM.intersectionWith (\vers cts -> (cts, vers)) (HM.fromList c) vv + fetchAppCategories :: MonadIO m => Key SApp -> ReaderT SqlBackend m [P.Entity ServiceCategory] fetchAppCategories appId = select $ do (categories :& service) <- @@ -429,35 +587,6 @@ fetchAppCategories appId = select $ do where_ (service ^. SAppId ==. val appId) pure categories -mapEntityToStoreApp :: MonadIO m => Entity SApp -> ReaderT SqlBackend m StoreApp -mapEntityToStoreApp serviceEntity = do - let service = entityVal serviceEntity - entityVersion <- fetchMostRecentAppVersions $ entityKey serviceEntity - let vers = entityVal <$> entityVersion - let vv = mapSVersionToVersionInfo vers - pure $ StoreApp { storeAppTitle = sAppTitle service - , storeAppDescShort = sAppDescShort service - , storeAppDescLong = sAppDescLong service - , storeAppVersionInfo = NE.fromList vv - , storeAppIconType = sAppIconType service - , storeAppTimestamp = Just (sAppCreatedAt service) -- case on if updatedAt? or always use updated time? was file timestamp - } - -mapEntityToServiceAvailable :: (MonadIO m, MonadHandler m) - => Text - -> Entity SApp - -> ReaderT SqlBackend m ServiceAvailable -mapEntityToServiceAvailable domain service = do - let appId = sAppAppId $ entityVal service - (_, v) <- fetchLatestApp appId >>= errOnNothing status404 "service not found" - let appVersion = sVersionNumber (entityVal v) - pure $ ServiceAvailable { serviceAvailableId = appId - , serviceAvailableTitle = sAppTitle $ entityVal service - , serviceAvailableDescShort = sAppDescShort $ entityVal service - , serviceAvailableVersion = appVersion - , serviceAvailableIcon = [i|https://#{domain}/package/icon/#{appId}?spec==#{appVersion}|] - } - -- >>> encode hm -- "{\"0.2.0\":\"some notes\"}" hm :: Data.Aeson.Value diff --git a/src/Handler/Types/Status.hs b/src/Handler/Types/Status.hs index 51b56f7..5c23e79 100644 --- a/src/Handler/Types/Status.hs +++ b/src/Handler/Types/Status.hs @@ -8,31 +8,20 @@ import Startlude hiding ( toLower ) import Data.Aeson import Yesod.Core.Content +import Data.Text import Lib.Types.Emver import Orphans.Emver ( ) -import Data.Text data AppVersionRes = AppVersionRes - { appVersionVersion :: Version - , appVersionMinCompanion :: Maybe Version - , appVersionReleaseNotes :: Maybe Text + { appVersionVersion :: Version } deriving (Eq, Show) instance ToJSON AppVersionRes where - toJSON AppVersionRes { appVersionVersion, appVersionMinCompanion, appVersionReleaseNotes } = - let rn = case appVersionReleaseNotes of - Nothing -> [] - Just x -> ["release-notes" .= x] - mc = case appVersionMinCompanion of - Nothing -> [] - Just x -> ["minCompanion" .= x] - in object $ ["version" .= appVersionVersion] <> mc <> rn + toJSON AppVersionRes { appVersionVersion } = object $ ["version" .= appVersionVersion] instance ToContent AppVersionRes where toContent = toContent . toJSON instance ToTypedContent AppVersionRes where toTypedContent = toTypedContent . toJSON - --- Ugh instance ToContent (Maybe AppVersionRes) where toContent = toContent . toJSON instance ToTypedContent (Maybe AppVersionRes) where @@ -47,9 +36,10 @@ instance ToJSON SystemStatus where toJSON = String . toLower . show data OSVersionRes = OSVersionRes - { osVersionStatus :: SystemStatus + { osVersionStatus :: SystemStatus , osVersionVersion :: Version - } deriving (Eq, Show) + } + deriving (Eq, Show) instance ToJSON OSVersionRes where toJSON OSVersionRes {..} = object ["status" .= osVersionStatus, "version" .= osVersionVersion] instance ToContent OSVersionRes where diff --git a/src/Handler/Version.hs b/src/Handler/Version.hs index 74cd75f..6839bbf 100644 --- a/src/Handler/Version.hs +++ b/src/Handler/Version.hs @@ -2,52 +2,34 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} module Handler.Version where import Startlude hiding ( Handler ) -import Control.Monad.Trans.Maybe import Yesod.Core +import Data.String.Interpolate.IsString + ( i ) import Foundation import Handler.Types.Status -import Lib.Registry -import Lib.Types.Emver +import Lib.Error ( S9Error(NotFoundE) ) +import Lib.PkgRepository ( getBestVersion ) +import Lib.Types.AppIndex ( PkgId ) +import Network.HTTP.Types.Status ( status404 ) import Settings -import System.FilePath ( () ) -import Util.Shared -import System.Directory ( doesFileExist ) +import Util.Shared ( getVersionSpecFromQuery + , orThrow + ) getVersionR :: Handler AppVersionRes -getVersionR = do - rv <- AppVersionRes . registryVersion . appSettings <$> getYesod - pure $ rv Nothing Nothing +getVersionR = AppVersionRes . registryVersion . appSettings <$> getYesod -getVersionAppR :: Text -> Handler (Maybe AppVersionRes) -getVersionAppR appId = do - (appsDir, appMgrDir) <- getsYesod $ (( "apps") . resourcesDir &&& staticBinDir) . appSettings - res <- getVersionWSpec appsDir appExt - case res of - Nothing -> pure res - Just r -> do - let appDir = (<> "/") . ( (show $ appVersionVersion r)) . ( toS appId) $ appsDir - addPackageHeader appMgrDir appDir appExt - pure res - where appExt = Extension (toS appId) :: Extension "s9pk" - --- @TODO - deprecate -getVersionSysR :: Text -> Handler (Maybe AppVersionRes) -getVersionSysR sysAppId = runMaybeT $ do - sysDir <- ( "sys") . resourcesDir . appSettings <$> getYesod - avr <- MaybeT $ getVersionWSpec sysDir sysExt - let notesPath = sysDir "agent" show (appVersionVersion avr) "release-notes.md" - notes <- liftIO $ ifM (doesFileExist notesPath) (Just <$> readFile notesPath) (pure Nothing) - pure $ avr { appVersionMinCompanion = Just $ Version (1, 1, 0, 0), appVersionReleaseNotes = notes } - where sysExt = Extension (toS sysAppId) :: Extension "" - -getVersionWSpec :: KnownSymbol a => FilePath -> Extension a -> Handler (Maybe AppVersionRes) -getVersionWSpec rootDir ext = do - av <- getVersionFromQuery rootDir ext - pure $ liftA3 AppVersionRes av (pure Nothing) (pure Nothing) +getPkgVersionR :: PkgId -> Handler AppVersionRes +getPkgVersionR pkg = do + spec <- getVersionSpecFromQuery + AppVersionRes <$> getBestVersion pkg spec `orThrow` sendResponseStatus + status404 + (NotFoundE [i|Version for #{pkg} satisfying #{spec}|]) diff --git a/src/Lib/Error.hs b/src/Lib/Error.hs index aa67125..7a6b0c7 100644 --- a/src/Lib/Error.hs +++ b/src/Lib/Error.hs @@ -5,15 +5,18 @@ module Lib.Error where import Startlude +import Data.String.Interpolate.IsString import Network.HTTP.Types import Yesod.Core -import Data.String.Interpolate.IsString type S9ErrT m = ExceptT S9Error m data S9Error = PersistentE Text - | AppMgrE Text Int + | AppMgrE Text ExitCode + | NotFoundE Text + | InvalidParamsE Text Text + | AssetParseE Text Text deriving (Show, Eq) instance Exception S9Error @@ -21,13 +24,18 @@ instance Exception S9Error -- | Redact any sensitive data in this function toError :: S9Error -> Error toError = \case - PersistentE t -> Error DATABASE_ERROR t - AppMgrE cmd code -> Error APPMGR_ERROR [i|"appmgr #{cmd}" exited with #{code}|] + PersistentE t -> Error DATABASE_ERROR t + AppMgrE cmd code -> Error APPMGR_ERROR [i|"appmgr #{cmd}" exited with #{code}|] + NotFoundE e -> Error NOT_FOUND [i|#{e}|] + InvalidParamsE e m -> Error INVALID_PARAMS [i|Could not parse request parameters #{e}: #{m}|] + AssetParseE asset found -> Error PARSE_ERROR [i|Could not parse #{asset}: #{found}|] data ErrorCode = DATABASE_ERROR | APPMGR_ERROR - + | NOT_FOUND + | INVALID_PARAMS + | PARSE_ERROR deriving (Eq, Show) instance ToJSON ErrorCode where toJSON = String . show @@ -51,8 +59,11 @@ instance ToContent S9Error where toStatus :: S9Error -> Status toStatus = \case - PersistentE _ -> status500 - AppMgrE _ _ -> status500 + PersistentE _ -> status500 + AppMgrE _ _ -> status500 + NotFoundE _ -> status404 + InvalidParamsE _ _ -> status400 + AssetParseE _ _ -> status500 handleS9ErrT :: MonadHandler m => S9ErrT m a -> m a diff --git a/src/Lib/External/AppMgr.hs b/src/Lib/External/AppMgr.hs index f5c9784..0db98bc 100644 --- a/src/Lib/External/AppMgr.hs +++ b/src/Lib/External/AppMgr.hs @@ -6,17 +6,39 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TemplateHaskell #-} module Lib.External.AppMgr where -import Startlude +import Startlude hiding ( bracket + , catch + , finally + , handle + ) import qualified Data.ByteString.Lazy as LBS import Data.String.Interpolate.IsString import System.Process.Typed hiding ( createPipe ) +import Conduit ( (.|) + , ConduitT + , runConduit + ) +import Control.Monad.Logger ( MonadLoggerIO + , logErrorSH + ) +import qualified Data.Conduit.List as CL +import Data.Conduit.Process.Typed +import GHC.IO.Exception ( IOErrorType(NoSuchThing) + , IOException(ioe_description, ioe_type) + ) import Lib.Error -import Lib.Registry +import System.FilePath ( () ) +import UnliftIO ( MonadUnliftIO + , catch + ) +import UnliftIO ( bracket ) readProcessWithExitCode' :: MonadIO m => String -> [String] -> ByteString -> m (ExitCode, ByteString, ByteString) readProcessWithExitCode' a b c = liftIO $ do @@ -31,57 +53,75 @@ readProcessWithExitCode' a b c = liftIO $ do (LBS.toStrict <$> getStdout process) (LBS.toStrict <$> getStderr process) -readProcessInheritStderr :: MonadIO m => String -> [String] -> ByteString -> m (ExitCode, ByteString) -readProcessInheritStderr a b c = liftIO $ do +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) - $ setStderr inherit $ setEnvInherit - $ setStdout byteStringOutput + $ setStderr (useHandleOpen stderr) + $ setStdout createSource $ System.Process.Typed.proc a b - withProcessWait pc - $ \process -> atomically $ liftA2 (,) (waitExitCodeSTM process) (LBS.toStrict <$> getStdout process) + 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' 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 + ) -getConfig :: (MonadIO m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> S9ErrT m Text -getConfig appmgrPath appPath e@(Extension appId) = fmap decodeUtf8 $ do - (ec, out) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk") - ["inspect", "config", appPath <> show e, "--json"] - "" - case ec of - ExitSuccess -> pure out - ExitFailure n -> throwE $ AppMgrE [i|info config #{appId} \--json|] n +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)) -getManifest :: (MonadIO m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> S9ErrT m ByteString -getManifest appmgrPath appPath e@(Extension appId) = do - (ec, bs) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "manifest", appPath <> show e] "" - case ec of - ExitSuccess -> pure bs - ExitFailure n -> throwE $ AppMgrE [i|embassy-sdk inspect manifest #{appId}|] n +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)) -getIcon :: (MonadIO m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> S9ErrT m ByteString -getIcon appmgrPath appPath e@(Extension icon) = do - (ec, bs) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "icon", appPath] "" - case ec of - ExitSuccess -> pure bs - ExitFailure n -> throwE $ AppMgrE [i|embassy-sdk inspect icon #{icon}|] n +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)) -getPackageHash :: (MonadIO m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> S9ErrT m ByteString -getPackageHash appmgrPath appPath e@(Extension appId) = do - (ec, bs) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "hash", appPath <> show e] "" - case ec of - ExitSuccess -> pure bs - ExitFailure n -> throwE $ AppMgrE [i|embassy-sdk inspect hash #{appId}|] n +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)) -getInstructions :: (MonadIO m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> S9ErrT m ByteString -getInstructions appmgrPath appPath e@(Extension appId) = do - (ec, bs) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "instructions", appPath] "" - case ec of - ExitSuccess -> pure bs - ExitFailure n -> throwE $ AppMgrE [i|embassy-sdk inspect instructions #{appId}|] n +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)) -getLicense :: (MonadIO m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> S9ErrT m ByteString -getLicense appmgrPath appPath e@(Extension appId) = do - (ec, bs) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "license", appPath] "" - case ec of - ExitSuccess -> pure bs - ExitFailure n -> throwE $ AppMgrE [i|embassy-sdk inspect license #{appId}|] n +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 new file mode 100644 index 0000000..f79d4d6 --- /dev/null +++ b/src/Lib/PkgRepository.hs @@ -0,0 +1,262 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DataKinds #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} +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 Data.Aeson ( eitherDecodeFileStrict' ) +import qualified Data.Attoparsec.Text as Atto +import Data.ByteString ( readFile + , writeFile + ) +import Data.String.Interpolate.IsString + ( i ) +import qualified Data.Text as T +import Lib.Error ( S9Error(NotFoundE) ) +import qualified Lib.External.AppMgr as AppMgr +import Lib.Types.AppIndex ( PkgId(..) + , ServiceManifest(serviceManifestIcon) + ) +import Lib.Types.Emver ( Version + , VersionRange + , parseVersion + , satisfies + ) +import Startlude ( ($) + , (&&) + , (.) + , (<$>) + , Bool(..) + , ByteString + , Down(..) + , Either(..) + , Eq((==)) + , Exception + , FilePath + , IO + , Integer + , Maybe(..) + , MonadIO(liftIO) + , MonadReader + , Show + , SomeException(..) + , filter + , find + , for_ + , fromMaybe + , headMay + , not + , partitionEithers + , pure + , show + , sortOn + , throwIO + , void + ) +import System.FSNotify ( ActionPredicate + , Event(..) + , eventPath + , watchTree + , withManager + ) +import System.FilePath ( (<.>) + , () + , takeBaseName + , takeDirectory + , takeExtension + ) +import UnliftIO ( MonadUnliftIO + , askRunInIO + , async + , mapConcurrently_ + , newEmptyMVar + , takeMVar + , wait + ) +import UnliftIO ( tryPutMVar ) +import UnliftIO.Concurrent ( forkIO ) +import UnliftIO.Directory ( getFileSize + , listDirectory + , removeFile + , renameFile + ) +import UnliftIO.Exception ( handle ) +import Yesod.Core.Content ( typeGif + , typeJpeg + , typePlain + , typePng + , typeSvg + ) +import Yesod.Core.Types ( ContentType ) + +data ManifestParseException = ManifestParseException FilePath + deriving Show +instance Exception ManifestParseException + +data PkgRepo = PkgRepo + { pkgRepoFileRoot :: FilePath + , pkgRepoAppMgrBin :: FilePath + } + +getVersionsFor :: (MonadIO m, MonadReader r m, Has PkgRepo r, MonadLogger m) => PkgId -> m [Version] +getVersionsFor pkg = do + root <- asks pkgRepoFileRoot + subdirs <- listDirectory $ root show pkg + let (failures, successes) = partitionEithers $ (Atto.parseOnly parseVersion . T.pack) <$> subdirs + for_ failures $ \f -> $logWarn [i|Emver Parse Failure for #{pkg}: #{f}|] + pure successes + +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 + -> m (Maybe Version) +getBestVersion pkg spec = headMay . sortOn Down <$> getViableVersions pkg spec + +-- extract all package assets into their own respective files +extractPkg :: (MonadUnliftIO m, MonadReader r m, Has PkgRepo r, MonadLoggerIO m) => FilePath -> m () +extractPkg fp = handle @_ @SomeException cleanup $ do + $logInfo [i|Extracting package: #{fp}|] + 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") + licenseTask <- async $ runResourceT $ AppMgr.sourceLicense appmgr fp $ sinkIt (pkgRoot "license.md") + iconTask <- async $ runResourceT $ AppMgr.sourceIcon appmgr fp $ sinkIt (pkgRoot "icon.tmp") + wait manifestTask + eManifest <- liftIO (eitherDecodeFileStrict' (pkgRoot "manifest.json")) + case eManifest of + Left _ -> do + $logError [i|Invalid Package Manifest: #{fp}|] + liftIO . throwIO $ ManifestParseException (pkgRoot "manifest.json") + Right manifest -> do + wait iconTask + let iconDest = "icon" <.> T.unpack (fromMaybe "png" (serviceManifestIcon manifest)) + liftIO $ renameFile (pkgRoot "icon.tmp") (pkgRoot iconDest) + hash <- wait pkgHashTask + liftIO $ writeFile (pkgRoot "hash.bin") hash + wait instructionsTask + wait licenseTask + where + sinkIt fp source = runConduit $ source .| sinkFileCautious fp + cleanup e = do + $logError $ show e + let pkgRoot = takeDirectory fp + fs <- listDirectory pkgRoot + let toRemove = filter (not . (== ".s9pk") . takeExtension) fs + mapConcurrently_ (removeFile . (pkgRoot )) toRemove + throwIO e + +watchPkgRepoRoot :: (MonadUnliftIO m, MonadReader r m, Has PkgRepo r, MonadLoggerIO m) => m (IO Bool) +watchPkgRepoRoot = do + $logInfo "Starting FSNotify Watch Manager" + root <- asks pkgRepoFileRoot + runInIO <- askRunInIO + box <- newEmptyMVar @_ @() + _ <- forkIO $ liftIO $ withManager $ \watchManager -> do + stop <- watchTree watchManager root onlyAdded $ \evt -> do + let pkg = eventPath evt + -- TODO: validate that package path is an actual s9pk and is in a correctly conforming path. + void . forkIO $ runInIO (extractPkg pkg) + takeMVar box + stop + pure $ tryPutMVar box () + where + onlyAdded :: ActionPredicate + onlyAdded (Added path _ isDir) = not isDir && takeExtension path == ".s9pk" + onlyAdded (Modified path _ isDir) = not isDir && takeExtension path == ".s9pk" + onlyAdded _ = False + -- Added path _ isDir -> not isDir && takeExtension path == ".s9pk" + +getManifest :: (MonadResource m, MonadReader r m, Has PkgRepo r) + => PkgId + -> Version + -> m (Integer, ConduitT () ByteString m ()) +getManifest pkg version = do + root <- asks pkgRepoFileRoot + let manifestPath = root show pkg show version "manifest.json" + n <- getFileSize manifestPath + pure $ (n, sourceFile manifestPath) + +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 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 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 + let ct = case takeExtension x of + ".png" -> typePng + ".jpg" -> typeJpeg + ".jpeg" -> typeJpeg + ".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 (Integer, ConduitT () ByteString m ()) +getPackage pkg version = do + root <- asks pkgRepoFileRoot + let pkgPath = root show pkg show version show pkg <.> "s9pk" + n <- getFileSize pkgPath + pure (n, sourceFile pkgPath) diff --git a/src/Lib/Types/AppIndex.hs b/src/Lib/Types/AppIndex.hs index da8bc99..40fad6f 100644 --- a/src/Lib/Types/AppIndex.hs +++ b/src/Lib/Types/AppIndex.hs @@ -14,39 +14,62 @@ import Data.Aeson import qualified Data.HashMap.Strict as HM import qualified Data.List.NonEmpty as NE +import qualified Data.ByteString.Lazy as BS +import Data.Functor.Contravariant ( Contravariant(contramap) ) +import Data.String.Interpolate.IsString +-- import Model +import qualified Data.Text as T +import Database.Persist.Postgresql +import qualified GHC.Read ( Read(..) ) +import qualified GHC.Show ( Show(..) ) +import Lib.Registry import Lib.Types.Emver import Orphans.Emver ( ) import System.Directory -import Lib.Registry -import Model -import qualified Data.Text as T -import Data.String.Interpolate.IsString -import qualified Data.ByteString.Lazy as BS +import Yesod -type AppIdentifier = Text +newtype PkgId = PkgId { unPkgId :: Text } + deriving (Eq) +instance IsString PkgId where + fromString = PkgId . fromString +instance 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 +instance ToContent PkgId where + toContent = toContent . toJSON +instance ToTypedContent PkgId where + toTypedContent = toTypedContent . toJSON data VersionInfo = VersionInfo { versionInfoVersion :: Version , versionInfoReleaseNotes :: Text - , versionInfoDependencies :: HM.HashMap AppIdentifier VersionRange + , versionInfoDependencies :: HM.HashMap PkgId VersionRange , versionInfoOsRequired :: VersionRange , versionInfoOsRecommended :: VersionRange , versionInfoInstallAlert :: Maybe Text } deriving (Eq, Show) -mapSVersionToVersionInfo :: [SVersion] -> [VersionInfo] -mapSVersionToVersionInfo sv = do - (\v -> VersionInfo { versionInfoVersion = sVersionNumber v - , versionInfoReleaseNotes = sVersionReleaseNotes v - , versionInfoDependencies = HM.empty - , versionInfoOsRequired = sVersionOsVersionRequired v - , versionInfoOsRecommended = sVersionOsVersionRecommended v - , versionInfoInstallAlert = Nothing - } - ) - <$> sv - instance Ord VersionInfo where compare = compare `on` versionInfoVersion @@ -88,7 +111,7 @@ instance ToJSON StoreApp where , "version-info" .= storeAppVersionInfo , "timestamp" .= storeAppTimestamp ] -newtype AppManifest = AppManifest { unAppManifest :: HM.HashMap AppIdentifier StoreApp} +newtype AppManifest = AppManifest { unAppManifest :: HM.HashMap PkgId StoreApp} deriving (Show) instance FromJSON AppManifest where @@ -128,11 +151,12 @@ addFileTimestamp appDir ext service v = do pure $ Just service { storeAppTimestamp = Just time } data ServiceDependencyInfo = ServiceDependencyInfo - { serviceDependencyInfoOptional :: Maybe Text - , serviceDependencyInfoVersion :: VersionRange + { serviceDependencyInfoOptional :: Maybe Text + , serviceDependencyInfoVersion :: VersionRange , serviceDependencyInfoDescription :: Maybe Text - , serviceDependencyInfoCritical :: Bool - } deriving (Show) + , serviceDependencyInfoCritical :: Bool + } + deriving Show instance FromJSON ServiceDependencyInfo where parseJSON = withObject "service dependency info" $ \o -> do serviceDependencyInfoOptional <- o .:? "optional" @@ -162,16 +186,17 @@ instance FromJSON ServiceAlert where "stop" -> pure STOP _ -> fail "unknown service alert type" data ServiceManifest = ServiceManifest - { serviceManifestId :: AppIdentifier - , serviceManifestTitle :: Text - , serviceManifestVersion :: Version - , serviceManifestDescriptionLong :: Text - , serviceManifestDescriptionShort :: Text - , serviceManifestReleaseNotes :: Text - , serviceManifestIcon :: Maybe Text - , serviceManifestAlerts :: HM.HashMap ServiceAlert (Maybe Text) - , serviceManifestDependencies :: HM.HashMap AppIdentifier ServiceDependencyInfo - } deriving (Show) + { serviceManifestId :: !PkgId + , serviceManifestTitle :: !Text + , serviceManifestVersion :: !Version + , serviceManifestDescriptionLong :: !Text + , serviceManifestDescriptionShort :: !Text + , serviceManifestReleaseNotes :: !Text + , serviceManifestIcon :: !(Maybe Text) + , serviceManifestAlerts :: !(HM.HashMap ServiceAlert (Maybe Text)) + , serviceManifestDependencies :: !(HM.HashMap PkgId ServiceDependencyInfo) + } + deriving Show instance FromJSON ServiceManifest where parseJSON = withObject "service manifest" $ \o -> do serviceManifestId <- o .: "id" @@ -203,7 +228,7 @@ instance ToJSON ServiceManifest where ] -- >>> eitherDecode testManifest :: Either String ServiceManifest --- Right (ServiceManifest {serviceManifestId = "embassy-pages", serviceManifestTitle = "Embassy Pages", serviceManifestVersion = 0.1.3, serviceManifestDescriptionLong = "Embassy Pages is a simple web server that uses directories inside File Browser to serve Tor websites.", serviceManifestDescriptionShort = "Create Tor websites, hosted on your Embassy.", serviceManifestReleaseNotes = "Upgrade to EmbassyOS v0.3.0", serviceManifestIcon = Just "icon.png", serviceManifestAlerts = fromList [(INSTALL,Nothing),(UNINSTALL,Nothing),(STOP,Nothing),(RESTORE,Nothing),(START,Nothing)], serviceManifestDependencies = fromList [("filebrowser",ServiceDependencyInfo {serviceDependencyInfoOptional = Nothing, serviceDependencyInfoVersion = >=2.14.1.1 <3.0.0, serviceDependencyInfoDescription = Just "Used to upload files to serve.", serviceDependencyInfoCritical = False})]}) +-- Right (ServiceManifest {serviceManifestId = embassy-pages, serviceManifestTitle = "Embassy Pages", serviceManifestVersion = 0.1.3, serviceManifestDescriptionLong = "Embassy Pages is a simple web server that uses directories inside File Browser to serve Tor websites.", serviceManifestDescriptionShort = "Create Tor websites, hosted on your Embassy.", serviceManifestReleaseNotes = "Upgrade to EmbassyOS v0.3.0", serviceManifestIcon = Just "icon.png", serviceManifestAlerts = fromList [(INSTALL,Nothing),(UNINSTALL,Nothing),(STOP,Nothing),(RESTORE,Nothing),(START,Nothing)], serviceManifestDependencies = fromList [(filebrowser,ServiceDependencyInfo {serviceDependencyInfoOptional = Nothing, serviceDependencyInfoVersion = >=2.14.1.1 <3.0.0, serviceDependencyInfoDescription = Just "Used to upload files to serve.", serviceDependencyInfoCritical = False})]}) testManifest :: BS.ByteString testManifest = [i|{ "id": "embassy-pages", diff --git a/src/Lib/Types/Category.hs b/src/Lib/Types/Category.hs index d302ae9..20aede7 100644 --- a/src/Lib/Types/Category.hs +++ b/src/Lib/Types/Category.hs @@ -1,5 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE DeriveGeneric #-} module Lib.Types.Category where @@ -16,7 +17,7 @@ data CategoryTitle = FEATURED | MESSAGING | SOCIAL | ALTCOIN - deriving (Eq, Enum, Show, Read) + deriving (Eq, Enum, Show, Read, Generic) instance PersistField CategoryTitle where fromPersistValue = fromPersistValueJSON toPersistValue = toPersistValueJSON @@ -46,3 +47,4 @@ instance ToContent CategoryTitle where toContent = toContent . toJSON instance ToTypedContent CategoryTitle where toTypedContent = toTypedContent . toJSON +instance Hashable CategoryTitle diff --git a/src/Lib/Types/Emver.hs b/src/Lib/Types/Emver.hs index 0c9a356..88d4b2f 100644 --- a/src/Lib/Types/Emver.hs +++ b/src/Lib/Types/Emver.hs @@ -34,28 +34,26 @@ module Lib.Types.Emver , exactly , parseVersion , parseRange - ) -where + ) where -import Prelude -import qualified Data.Attoparsec.Text as Atto -import Data.Function -import Data.Functor ( (<&>) - , ($>) - ) -import Control.Applicative ( liftA2 - , Alternative((<|>)) - ) -import Data.String ( IsString(..) ) -import qualified Data.Text as T +import Startlude hiding ( Any ) + +import Control.Monad.Fail ( fail ) import Data.Aeson -import Startlude ( Hashable ) +import qualified Data.Attoparsec.Text as Atto +import qualified Data.Text as T +import GHC.Base ( error ) +import qualified GHC.Read as GHC + ( readsPrec ) +import qualified GHC.Show as GHC + ( show ) -- | AppVersion is the core representation of the SemverQuad type. newtype Version = Version { unVersion :: (Word, Word, Word, Word) } deriving (Eq, Ord, ToJSONKey, Hashable) instance Show Version where show (Version (x, y, z, q)) = - let postfix = if q == 0 then "" else '.' : show q in show x <> "." <> show y <> "." <> show z <> postfix + let postfix = if q == 0 then "" else '.' : GHC.show q + in GHC.show x <> "." <> GHC.show y <> "." <> GHC.show z <> postfix instance IsString Version where fromString s = either error id $ Atto.parseOnly parseVersion (T.pack s) instance Read Version where @@ -135,17 +133,17 @@ exactly :: Version -> VersionRange exactly = Anchor (Right EQ) instance Show VersionRange where - show (Anchor ( Left EQ) v ) = '!' : '=' : show v - show (Anchor ( Right EQ) v ) = '=' : show v - show (Anchor ( Left LT) v ) = '>' : '=' : show v - show (Anchor ( Right LT) v ) = '<' : show v - show (Anchor ( Left GT) v ) = '<' : '=' : show v - show (Anchor ( Right GT) v ) = '>' : show v - show (Conj a@(Disj _ _) b@(Disj _ _)) = paren (show a) <> (' ' : paren (show b)) - show (Conj a@(Disj _ _) b ) = paren (show a) <> (' ' : show b) - show (Conj a b@(Disj _ _)) = show a <> (' ' : paren (show b)) - show (Conj a b ) = show a <> (' ' : show b) - show (Disj a b ) = show a <> " || " <> show b + show (Anchor ( Left EQ) v ) = '!' : '=' : GHC.show v + show (Anchor ( Right EQ) v ) = '=' : GHC.show v + show (Anchor ( Left LT) v ) = '>' : '=' : GHC.show v + show (Anchor ( Right LT) v ) = '<' : GHC.show v + show (Anchor ( Left GT) v ) = '<' : '=' : GHC.show v + show (Anchor ( Right GT) v ) = '>' : GHC.show v + show (Conj a@(Disj _ _) b@(Disj _ _)) = paren (GHC.show a) <> (' ' : paren (GHC.show b)) + show (Conj a@(Disj _ _) b ) = paren (GHC.show a) <> (' ' : GHC.show b) + show (Conj a b@(Disj _ _)) = GHC.show a <> (' ' : paren (GHC.show b)) + show (Conj a b ) = GHC.show a <> (' ' : GHC.show b) + show (Disj a b ) = GHC.show a <> " || " <> GHC.show b show Any = "*" show None = "!" instance Read VersionRange where @@ -184,10 +182,6 @@ satisfies _ None = False (||>) = flip satisfies {-# INLINE (||>) #-} -(<<$>>) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b) -(<<$>>) = fmap . fmap -{-# INLINE (<<$>>) #-} - parseOperator :: Atto.Parser Operator parseOperator = (Atto.char '=' $> Right EQ) diff --git a/src/Model.hs b/src/Model.hs index 30373de..1527183 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -10,18 +10,19 @@ module Model where -import Startlude import Database.Persist.TH -import Lib.Types.Emver +import Lib.Types.AppIndex import Lib.Types.Category +import Lib.Types.Emver import Orphans.Emver ( ) +import Startlude share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| SApp createdAt UTCTime updatedAt UTCTime Maybe title Text - appId Text + appId PkgId descShort Text descLong Text iconType Text @@ -63,8 +64,8 @@ Category name CategoryTitle parent CategoryId Maybe description Text - UniqueName name priority Int default=0 + UniqueName name deriving Eq deriving Show diff --git a/src/Orphans/Emver.hs b/src/Orphans/Emver.hs index 24976a3..10be872 100644 --- a/src/Orphans/Emver.hs +++ b/src/Orphans/Emver.hs @@ -9,10 +9,10 @@ import Startlude import Data.Aeson import qualified Data.Attoparsec.Text as Atto -import Lib.Types.Emver -import Database.Persist.Sql -import qualified Data.Text as T import Control.Monad.Fail ( MonadFail(fail) ) +import qualified Data.Text as T +import Database.Persist.Sql +import Lib.Types.Emver instance FromJSON Version where parseJSON = withText "Emver Version" $ either fail pure . Atto.parseOnly parseVersion diff --git a/src/Settings.hs b/src/Settings.hs index da08761..eca9ddb 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -1,5 +1,6 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MultiParamTypeClasses #-} -- | Settings are centralized, as much as possible, into this file. This -- includes database connection settings, static file locations, etc. -- In addition, you can configure a number of different aspects of Yesod @@ -23,8 +24,9 @@ import Network.Wai.Handler.Warp ( HostPreference ) import System.FilePath ( () ) import Yesod.Default.Config2 ( configSettingsYml ) +import Control.Monad.Reader.Has ( Has(extract, update) ) +import Lib.PkgRepository ( PkgRepo(..) ) import Lib.Types.Emver -import Network.Wai ( FilePart ) import Orphans.Emver ( ) -- | Runtime settings to configure this application. These settings can be -- loaded from various sources: defaults, environment variables, config files, @@ -55,6 +57,11 @@ data AppSettings = AppSettings , staticBinDir :: FilePath , errorLogRoot :: FilePath } +instance Has PkgRepo AppSettings where + extract = liftA2 PkgRepo (( "apps") . resourcesDir) staticBinDir + update f r = + let repo = f $ extract r in r { resourcesDir = pkgRepoFileRoot repo, staticBinDir = pkgRepoAppMgrBin repo } + instance FromJSON AppSettings where parseJSON = withObject "AppSettings" $ \o -> do diff --git a/src/Util/Function.hs b/src/Util/Function.hs index cb5c771..fb20345 100644 --- a/src/Util/Function.hs +++ b/src/Util/Function.hs @@ -21,3 +21,6 @@ mapFind finder mapping (b : bs) = (Nothing, Just _) -> Just b _ -> Nothing +(<<&>>) :: (Functor f, Functor g) => f (g a) -> (a -> b) -> f (g b) +f <<&>> fab = fmap (fmap fab) f + diff --git a/src/Util/Shared.hs b/src/Util/Shared.hs index 03a2daa..58b370e 100644 --- a/src/Util/Shared.hs +++ b/src/Util/Shared.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} module Util.Shared where @@ -8,34 +9,27 @@ import qualified Data.Text as T import Network.HTTP.Types import Yesod.Core +import Control.Monad.Reader.Has ( Has ) import Foundation -import Lib.Registry +import Lib.PkgRepository ( PkgRepo + , getHash + ) +import Lib.Types.AppIndex ( PkgId ) import Lib.Types.Emver -import Data.Semigroup -import Lib.External.AppMgr -import Lib.Error -getVersionFromQuery :: KnownSymbol a => FilePath -> Extension a -> Handler (Maybe Version) -getVersionFromQuery rootDir ext = do +getVersionSpecFromQuery :: Handler VersionRange +getVersionSpecFromQuery = do specString <- T.filter (not . isSpace) . fromMaybe "*" <$> lookupGetParam "spec" - spec <- case readMaybe specString of + case readMaybe specString of Nothing -> sendResponseStatus status400 ("Invalid App Version Specification" :: Text) Just t -> pure t - getBestVersion rootDir ext spec -getBestVersion :: (MonadIO m, KnownSymbol a, MonadLogger m) - => FilePath - -> Extension a - -> VersionRange - -> m (Maybe Version) -getBestVersion rootDir ext spec = do - -- @TODO change to db query? - appVersions <- liftIO $ getAvailableAppVersions rootDir ext - let satisfactory = filter ((<|| spec) . fst . unRegisteredAppVersion) appVersions - let best = getMax <$> foldMap (Just . Max . fst . unRegisteredAppVersion) satisfactory - pure best - -addPackageHeader :: (MonadHandler m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> m () -addPackageHeader appMgrDir appDir appExt = do - packageHash <- handleS9ErrT $ getPackageHash appMgrDir appDir appExt +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 diff --git a/stack.yaml b/stack.yaml index aa4d54e..9739af5 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.6 +resolver: lts-18.11 # User packages to be built. # Various formats can be used as shown in the example below. @@ -29,7 +29,7 @@ resolver: lts-18.6 # - auto-update # - wai packages: -- . + - . # Dependency packages to be pulled from upstream that are not in the resolver. # These entries can reference officially published versions as well as # forks / in-progress versions pinned to a git hash. For example: @@ -42,8 +42,8 @@ packages: extra-deps: - protolude-0.3.0 - esqueleto-3.5.1.0 + - monad-logger-extras-0.1.1.1 - wai-request-spec-0.10.2.4 - # Override default flag values for local packages and extra-deps # flags: {} @@ -68,4 +68,4 @@ extra-deps: # Allow a newer minor version of GHC than the snapshot specifies # compiler-check: newer-minor # docker: - # enable: true +# enable: true diff --git a/test/Handler/AppSpec.hs b/test/Handler/AppSpec.hs index 46b860e..893afd2 100644 --- a/test/Handler/AppSpec.hs +++ b/test/Handler/AppSpec.hs @@ -14,68 +14,65 @@ import Model spec :: Spec spec = do - describe "GET /apps" $ withApp $ it "returns list of apps" $ do + describe "GET /package/index" $ withApp $ it "returns list of apps" $ do request $ do setMethod "GET" - setUrl ("/apps" :: Text) - bodyContains "bitcoind" - bodyContains "version: 0.18.1" + setUrl ("/package/index" :: Text) + bodyContains "embassy-pages" + bodyContains "version: 0.1.3" statusIs 200 - describe "GET /apps/:appId with unknown version spec for bitcoin" $ withApp $ it "fails to get unknown app" $ do + describe "GET /package/:appId with unknown version spec for embassy-pages" + $ withApp + $ it "fails to get unknown app" + $ do + request $ do + setMethod "GET" + setUrl ("/package/embassy-pages.s9pk?spec=0.1.4" :: Text) + statusIs 404 + describe "GET /package/:appId with unknown app" $ withApp $ it "fails to get an unregistered app" $ do request $ do setMethod "GET" - setUrl ("/apps/bitcoind.s9pk?spec=0.18.3" :: Text) + setUrl ("/package/tempapp.s9pk?spec=0.0.1" :: Text) statusIs 404 - describe "GET /apps/:appId with unknown app" $ withApp $ it "fails to get an unregistered app" $ do - request $ do - setMethod "GET" - setUrl ("/apps/tempapp.s9pk?spec=0.0.1" :: Text) - statusIs 404 - describe "GET /apps/:appId with existing version spec for bitcoin" + describe "GET /package/:appId with existing version spec for embassy-pages" $ withApp $ it "creates app and metric records" $ do request $ do setMethod "GET" - setUrl ("/apps/bitcoind.s9pk?spec==0.18.1" :: Text) + setUrl ("/package/embassy-pages.s9pk?spec==0.1.3" :: Text) statusIs 200 - apps <- runDBtest $ selectList [SAppAppId ==. "bitcoind"] [] + apps <- runDBtest $ selectList [SAppAppId ==. "embassy-pages"] [] assertEq "app should exist" (length apps) 1 let app = fromJust $ head apps metrics <- runDBtest $ selectList [MetricAppId ==. entityKey app] [] assertEq "metric should exist" (length metrics) 1 - describe "GET /apps/:appId with existing version spec for cups" $ withApp $ it "creates app and metric records" $ do - request $ do - setMethod "GET" - setUrl ("/apps/cups.s9pk?spec=0.2.1" :: Text) - statusIs 200 - apps <- runDBtest $ selectList [SAppAppId ==. "cups"] [] - assertEq "app should exist" (length apps) 1 - let app = fromJust $ head apps - metrics <- runDBtest $ selectList [MetricAppId ==. entityKey app] [] - assertEq "metric should exist" (length metrics) 1 - version <- runDBtest $ selectList [SVersionAppId ==. entityKey app] [] - assertEq "version should exist" (length version) 1 + describe "GET /package/:appId with existing version spec for filebrowser" + $ withApp + $ it "creates app and metric records" + $ do + request $ do + setMethod "GET" + setUrl ("/package/filebrowser.s9pk?spec==2.14.1.1" :: Text) + statusIs 200 + apps <- runDBtest $ selectList [SAppAppId ==. "filebrowser"] [] + assertEq "app should exist" (length apps) 1 + let app = fromJust $ head apps + metrics <- runDBtest $ selectList [MetricAppId ==. entityKey app] [] + assertEq "metric should exist" (length metrics) 1 + version <- runDBtest $ selectList [SVersionAppId ==. entityKey app] [] + assertEq "version should exist" (length version) 1 describe "GET /sys/proxy.pac" $ withApp $ it "does not record metric but request successful" $ do request $ do setMethod "GET" setUrl ("/sys/proxy.pac?spec=0.1.0" :: Text) statusIs 200 - -- select * from s_app apps <- runDBtest $ selectList ([] :: [Filter SApp]) [] assertEq "no apps should exist" (length apps) 0 describe "GET /sys/:sysId" $ withApp $ it "does not record metric but request successful" $ do request $ do setMethod "GET" - setUrl ("/sys/agent?spec=0.0.0" :: Text) + setUrl ("/sys/appmgr?spec=0.0.0" :: Text) statusIs 200 apps <- runDBtest $ selectList ([] :: [Filter SApp]) [] assertEq "no apps should exist" (length apps) 0 - -- @TODO uncomment when new portable appmgr live - xdescribe "GET /apps/manifest/#S9PK" $ withApp $ it "gets bitcoin manifest" $ do - request $ do - setMethod "GET" - setUrl ("/apps/manifest/bitcoind?spec==0.20.1" :: Text) - statusIs 200 - bodyContains - "{\"id\":\"bitcoind\",\"version\":\"0.20.1\",\"title\":\"Bitcoin Core\",\"description\":{\"short\":\"Bitcoin Full Node by Bitcoin Core\",\"long\":\"Bitcoin is an innovative payment network and a new kind of money. Bitcoin uses peer-to-peer technology to operate with no central authority or banks; managing transactions and the issuing of bitcoins is carried out collectively by the network. Bitcoin is open-source; its design is public, nobody owns or controls Bitcoin and everyone can take part. Through many of its unique properties, Bitcoin allows exciting uses that could not be covered by any previous payment system.\"},\"release-notes\":\"https://github.com/bitcoin/bitcoin/blob/master/doc/release-notes/release-notes-0.20.1.md\",\"has-instructions\":true,\"os-version-required\":\">=0.2.4\",\"os-version-recommended\":\">=0.2.4\",\"ports\":[{\"internal\":8332,\"tor\":8332},{\"internal\":8333,\"tor\":8333}],\"image\":{\"type\":\"tar\"},\"mount\":\"/root/.bitcoin\",\"assets\":[{\"src\":\"bitcoin.conf.template\",\"dst\":\".\",\"overwrite\":true}],\"hidden-service-version\":\"v2\",\"dependencies\":{}}" diff --git a/test/Handler/MarketplaceSpec.hs b/test/Handler/MarketplaceSpec.hs index c7d87f8..4422caa 100644 --- a/test/Handler/MarketplaceSpec.hs +++ b/test/Handler/MarketplaceSpec.hs @@ -33,14 +33,14 @@ spec = do "short desc lnd" "long desc lnd" "png" - featuredCat <- runDBtest $ insert $ Category time FEATURED Nothing "desc" - btcCat <- runDBtest $ insert $ Category time BITCOIN Nothing "desc" - lnCat <- runDBtest $ insert $ Category time LIGHTNING Nothing "desc" + featuredCat <- runDBtest $ insert $ Category time FEATURED Nothing "desc" 0 + btcCat <- runDBtest $ insert $ Category time BITCOIN Nothing "desc" 0 + lnCat <- runDBtest $ insert $ Category time LIGHTNING Nothing "desc" 0 _ <- runDBtest $ insert_ $ ServiceCategory time btc featuredCat "bitcoin" FEATURED Nothing _ <- runDBtest $ insert_ $ ServiceCategory time lnd lnCat "lnd" LIGHTNING Nothing _ <- runDBtest $ insert_ $ ServiceCategory time lnd btcCat "lnd" BITCOIN Nothing _ <- runDBtest $ insert_ $ ServiceCategory time btc btcCat "bitcon" BITCOIN Nothing - apps <- runDBtest $ searchServices FEATURED 20 0 "" + apps <- runDBtest $ searchServices (Just FEATURED) 20 0 "" assertEq "should exist" (length apps) 1 let app' = fromJust $ head apps assertEq "should be bitcoin" (sAppTitle $ entityVal app') "Bitcoin Core" @@ -60,14 +60,14 @@ spec = do "short desc lnd" "long desc lnd" "png" - featuredCat <- runDBtest $ insert $ Category time FEATURED Nothing "desc" - btcCat <- runDBtest $ insert $ Category time BITCOIN Nothing "desc" - lnCat <- runDBtest $ insert $ Category time LIGHTNING Nothing "desc" - _ <- runDBtest $ insert_ $ ServiceCategory time btc featuredCat "bitcoin" FEATURED Nothing + featuredCat <- runDBtest $ insert $ Category time FEATURED Nothing "desc" 0 + btcCat <- runDBtest $ insert $ Category time BITCOIN Nothing "desc" 0 + lnCat <- runDBtest $ insert $ Category time LIGHTNING Nothing "desc" 0 + _ <- runDBtest $ insert_ $ ServiceCategory time btc featuredCat "bitcoind" FEATURED Nothing _ <- runDBtest $ insert_ $ ServiceCategory time lnd lnCat "lnd" LIGHTNING Nothing _ <- runDBtest $ insert_ $ ServiceCategory time lnd btcCat "lnd" BITCOIN Nothing - _ <- runDBtest $ insert_ $ ServiceCategory time btc btcCat "bitcon" BITCOIN Nothing - apps <- runDBtest $ searchServices BITCOIN 20 0 "" + _ <- runDBtest $ insert_ $ ServiceCategory time btc btcCat "bitcoind" BITCOIN Nothing + apps <- runDBtest $ searchServices (Just BITCOIN) 20 0 "" assertEq "should exist" (length apps) 2 describe "searchServices with fuzzy query" $ withApp @@ -88,10 +88,10 @@ spec = do "short desc" "lightning long desc" "png" - cate <- runDBtest $ insert $ Category time FEATURED Nothing "desc" + cate <- runDBtest $ insert $ Category time FEATURED Nothing "desc" 0 _ <- runDBtest $ insert_ $ ServiceCategory time app1 cate "bitcoind" FEATURED Nothing _ <- runDBtest $ insert_ $ ServiceCategory time app2 cate "lnd" FEATURED Nothing - apps <- runDBtest $ searchServices FEATURED 20 0 "lightning" + apps <- runDBtest $ searchServices (Just FEATURED) 20 0 "lightning" assertEq "should exist" (length apps) 1 let app' = fromJust $ head apps print app' @@ -104,8 +104,9 @@ spec = do "short desc bitcoin" "long desc bitcoin" "png" - _ <- runDBtest $ insert $ SVersion time (Just time) btc "0.19.0" "notes" Any Any - _ <- runDBtest $ insert $ SVersion time (Just time) btc "0.20.0" "notes" Any Any + print btc + _ <- runDBtest $ insert $ SVersion time (Just time) btc "0.19.0" "notes" Any Any Nothing + _ <- runDBtest $ insert $ SVersion time (Just time) btc "0.20.0" "notes" Any Any Nothing lnd <- runDBtest $ insert $ SApp time (Just time) "Lightning Network Daemon" @@ -113,22 +114,23 @@ spec = do "short desc lnd" "long desc lnd" "png" - _ <- runDBtest $ insert $ SVersion time (Just time) lnd "0.18.0" "notes" Any Any - _ <- runDBtest $ insert $ SVersion time (Just time) lnd "0.17.0" "notes" Any Any - featuredCat <- runDBtest $ insert $ Category time FEATURED Nothing "desc" - btcCat <- runDBtest $ insert $ Category time BITCOIN Nothing "desc" - lnCat <- runDBtest $ insert $ Category time LIGHTNING Nothing "desc" + _ <- runDBtest $ insert $ SVersion time (Just time) lnd "0.18.0" "notes" Any Any Nothing + _ <- runDBtest $ insert $ SVersion time (Just time) lnd "0.17.0" "notes" Any Any Nothing + featuredCat <- runDBtest $ insert $ Category time FEATURED Nothing "desc" 0 + btcCat <- runDBtest $ insert $ Category time BITCOIN Nothing "desc" 0 + lnCat <- runDBtest $ insert $ Category time LIGHTNING Nothing "desc" 0 _ <- runDBtest $ insert_ $ ServiceCategory time btc featuredCat "bitcoin" FEATURED Nothing _ <- runDBtest $ insert_ $ ServiceCategory time lnd lnCat "lnd" LIGHTNING Nothing _ <- runDBtest $ insert_ $ ServiceCategory time lnd btcCat "lnd" BITCOIN Nothing _ <- runDBtest $ insert_ $ ServiceCategory time btc btcCat "bitcon" BITCOIN Nothing - apps <- runDBtest $ searchServices ANY 20 0 "" + apps <- runDBtest $ searchServices Nothing 20 0 "" assertEq "should exist" (length apps) 2 - -- describe "getServiceVersionsWithReleaseNotes" $ - -- withApp $ it "gets service with mapping of version to release notes" $ do - -- time <- liftIO getCurrentTime - -- app <- runDBtest $ insert $ SApp time Nothing "Bitcoin Core" "bitcoin" "short desc" "long desc" "png" - -- _ <- runDBtest $ insert $ SVersion time Nothing app "0.19.0.0" "release notes 0.19.0.0" "*" "*" - -- _ <- runDBtest $ insert $ SVersion time Nothing app "0.20.0.0" "release notes 0.19.0.0" "*" "*" - -- res <- runDBtest $ getServiceVersionsWithReleaseNotes "bitcoin" - -- print res + xdescribe "getServiceVersionsWithReleaseNotes" + $ withApp + $ it "gets service with mapping of version to release notes" + $ do + time <- liftIO getCurrentTime + app <- runDBtest $ insert $ SApp time Nothing "Bitcoin Core" "bitcoin" "short desc" "long desc" "png" + _ <- runDBtest $ insert $ SVersion time Nothing app "0.19.0.0" "release notes 0.19.0.0" Any Any Nothing + _ <- runDBtest $ insert $ SVersion time Nothing app "0.20.0.0" "release notes 0.19.0.0" Any Any Nothing + print ()