mirror of
https://github.com/Start9Labs/registry.git
synced 2026-03-26 02:11:53 +00:00
Lucy C
7
.gitignore
vendored
7
.gitignore
vendored
@@ -30,4 +30,9 @@ version
|
||||
**/*.s9pk
|
||||
**/appmgr
|
||||
0.3.0_features.md
|
||||
**/embassy-sdk
|
||||
**/embassy-sdk
|
||||
start9-registry.prof
|
||||
start9-registry.hp
|
||||
start9-registry.pdf
|
||||
start9-registry.aux
|
||||
start9-registry.ps
|
||||
@@ -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=<pacakge-id>
|
||||
/package/icon/#AppIdentifier IconsR GET -- get icons - can specify version with ?spec=<emver>
|
||||
/package/license/#AppIdentifier LicenseR GET -- get icons - can specify version with ?spec=<emver>
|
||||
/package/instructions/#AppIdentifier InstructionsR GET -- get icons - can specify version with ?spec=<emver>
|
||||
|
||||
-- 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=<emver>
|
||||
/package/license/#PkgId LicenseR GET -- get icons - can specify version with ?spec=<emver>
|
||||
/package/instructions/#PkgId InstructionsR GET -- get icons - can specify version with ?spec=<emver>
|
||||
/package/version/#PkgId PkgVersionR GET -- get most recent appId version
|
||||
|
||||
/error-logs ErrorLogsR POST
|
||||
109
package.yaml
109
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
|
||||
|
||||
@@ -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: '*'
|
||||
@@ -1 +0,0 @@
|
||||
appmgr downloaded
|
||||
@@ -1 +0,0 @@
|
||||
image downloaded
|
||||
@@ -1 +0,0 @@
|
||||
get it all up down around
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
)
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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)
|
||||
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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" "<MISSING>")
|
||||
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" "<MISSING>")
|
||||
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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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}|])
|
||||
|
||||
@@ -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
|
||||
|
||||
132
src/Lib/External/AppMgr.hs
vendored
132
src/Lib/External/AppMgr.hs
vendored
@@ -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
|
||||
|
||||
262
src/Lib/PkgRepository.hs
Normal file
262
src/Lib/PkgRepository.hs
Normal file
@@ -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)
|
||||
@@ -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",
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -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
|
||||
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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\":{}}"
|
||||
|
||||
@@ -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 ()
|
||||
|
||||
Reference in New Issue
Block a user