mirror of
https://github.com/Start9Labs/registry.git
synced 2026-03-30 11:51:57 +00:00
Lucy C
7
.gitignore
vendored
7
.gitignore
vendored
@@ -30,4 +30,9 @@ version
|
|||||||
**/*.s9pk
|
**/*.s9pk
|
||||||
**/appmgr
|
**/appmgr
|
||||||
0.3.0_features.md
|
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/#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/data CategoriesR GET -- get all marketplace categories
|
||||||
/package/index PackageListR GET -- filter marketplace services by various query params
|
/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
|
/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/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/icon/#PkgId IconsR GET -- get icons - can specify version with ?spec=<emver>
|
||||||
/package/license/#AppIdentifier LicenseR GET -- get icons - can specify version with ?spec=<emver>
|
/package/license/#PkgId LicenseR GET -- get icons - can specify version with ?spec=<emver>
|
||||||
/package/instructions/#AppIdentifier InstructionsR 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
|
||||||
-- 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
|
|
||||||
|
|
||||||
/error-logs ErrorLogsR POST
|
/error-logs ErrorLogsR POST
|
||||||
109
package.yaml
109
package.yaml
@@ -2,60 +2,65 @@ name: start9-registry
|
|||||||
version: 0.1.0
|
version: 0.1.0
|
||||||
|
|
||||||
default-extensions:
|
default-extensions:
|
||||||
- FlexibleInstances
|
- FlexibleInstances
|
||||||
- GeneralizedNewtypeDeriving
|
- GeneralizedNewtypeDeriving
|
||||||
- LambdaCase
|
- LambdaCase
|
||||||
- MultiWayIf
|
- MultiWayIf
|
||||||
- NamedFieldPuns
|
- NamedFieldPuns
|
||||||
- NoImplicitPrelude
|
- NoImplicitPrelude
|
||||||
- NumericUnderscores
|
- NumericUnderscores
|
||||||
- OverloadedStrings
|
- OverloadedStrings
|
||||||
- StandaloneDeriving
|
- StandaloneDeriving
|
||||||
|
|
||||||
dependencies:
|
dependencies:
|
||||||
- base >=4.12 && <5
|
- base >=4.12 && <5
|
||||||
- aeson
|
- aeson
|
||||||
- attoparsec
|
- ansi-terminal
|
||||||
- bytestring
|
- attoparsec
|
||||||
- casing
|
- bytestring
|
||||||
- conduit
|
- casing
|
||||||
- conduit-extra
|
- can-i-haz
|
||||||
- data-default
|
- conduit
|
||||||
- directory
|
- conduit-extra
|
||||||
- errors
|
- data-default
|
||||||
- extra
|
- directory
|
||||||
- file-embed
|
- errors
|
||||||
- fast-logger
|
- esqueleto
|
||||||
- filepath
|
- extra
|
||||||
- http-types
|
- file-embed
|
||||||
- interpolate
|
- fast-logger
|
||||||
- lens
|
- filepath
|
||||||
- monad-logger
|
- foreign-store
|
||||||
- persistent
|
- fsnotify
|
||||||
- persistent-postgresql
|
- http-types
|
||||||
- persistent-template
|
- interpolate
|
||||||
- process
|
- lens
|
||||||
- protolude
|
- monad-logger
|
||||||
- shakespeare
|
- monad-logger-extras
|
||||||
- template-haskell
|
- parallel
|
||||||
- text
|
- persistent
|
||||||
- time
|
- persistent-postgresql
|
||||||
- transformers
|
- persistent-template
|
||||||
- typed-process
|
- process
|
||||||
- unordered-containers
|
- protolude
|
||||||
- unix
|
- shakespeare
|
||||||
- wai
|
- template-haskell
|
||||||
- wai-cors
|
- text
|
||||||
- wai-extra
|
- time
|
||||||
- warp
|
- transformers
|
||||||
- warp-tls
|
- typed-process
|
||||||
- yaml
|
- unliftio
|
||||||
- yesod
|
- unordered-containers
|
||||||
- yesod-core
|
- unix
|
||||||
- yesod-persistent
|
- wai
|
||||||
- esqueleto
|
- wai-cors
|
||||||
- text-conversions
|
- wai-extra
|
||||||
- foreign-store
|
- warp
|
||||||
|
- warp-tls
|
||||||
|
- yaml
|
||||||
|
- yesod
|
||||||
|
- yesod-core
|
||||||
|
- yesod-persistent
|
||||||
|
|
||||||
library:
|
library:
|
||||||
source-dirs: src
|
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
|
, getAppSettings
|
||||||
-- * for GHCI
|
-- * for GHCI
|
||||||
, handler
|
, handler
|
||||||
|
, db
|
||||||
) where
|
) 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 Data.Default
|
||||||
import Database.Persist.Postgresql (createPostgresqlPool, pgConnStr, pgPoolSize, runSqlPool, runMigration)
|
import Database.Persist.Postgresql ( createPostgresqlPool
|
||||||
import Language.Haskell.TH.Syntax (qLocation)
|
, pgConnStr
|
||||||
|
, pgPoolSize
|
||||||
|
, runMigration
|
||||||
|
, runSqlPool
|
||||||
|
)
|
||||||
|
import Language.Haskell.TH.Syntax ( qLocation )
|
||||||
import Network.Wai
|
import Network.Wai
|
||||||
import Network.Wai.Handler.Warp (Settings, defaultSettings, defaultShouldDisplayException,
|
import Network.Wai.Handler.Warp ( Settings
|
||||||
getPort, setHost, setOnException, setPort, runSettings, setHTTP2Disabled)
|
, defaultSettings
|
||||||
|
, defaultShouldDisplayException
|
||||||
|
, getPort
|
||||||
|
, runSettings
|
||||||
|
, setHTTP2Disabled
|
||||||
|
, setHost
|
||||||
|
, setOnException
|
||||||
|
, setPort
|
||||||
|
)
|
||||||
import Network.Wai.Handler.WarpTLS
|
import Network.Wai.Handler.WarpTLS
|
||||||
import Network.Wai.Middleware.AcceptOverride
|
import Network.Wai.Middleware.AcceptOverride
|
||||||
import Network.Wai.Middleware.Autohead
|
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.MethodOverride
|
||||||
import Network.Wai.Middleware.RequestLogger (Destination (Logger), OutputFormat (..),
|
import Network.Wai.Middleware.RequestLogger
|
||||||
destination, mkRequestLogger, outputFormat)
|
( Destination(Logger)
|
||||||
import System.IO (hSetBuffering, BufferMode (..))
|
, OutputFormat(..)
|
||||||
import System.Log.FastLogger (defaultBufSize, newStdoutLoggerSet, toLogStr)
|
, destination
|
||||||
|
, mkRequestLogger
|
||||||
|
, outputFormat
|
||||||
|
)
|
||||||
|
import System.IO ( BufferMode(..)
|
||||||
|
, hSetBuffering
|
||||||
|
)
|
||||||
|
import System.Log.FastLogger ( defaultBufSize
|
||||||
|
, newStdoutLoggerSet
|
||||||
|
, toLogStr
|
||||||
|
)
|
||||||
import Yesod.Core
|
import Yesod.Core
|
||||||
import Yesod.Core.Types hiding (Logger)
|
import Yesod.Core.Types hiding ( Logger )
|
||||||
import Yesod.Default.Config2
|
import Yesod.Default.Config2
|
||||||
|
|
||||||
-- Import all relevant handler modules here.
|
import Control.Arrow ( (***) )
|
||||||
-- Don't forget to add new modules to your cabal file!
|
import Control.Lens
|
||||||
|
import Data.List ( lookup )
|
||||||
|
import Data.String.Interpolate.IsString
|
||||||
|
( i )
|
||||||
|
import Database.Persist.Sql ( SqlBackend )
|
||||||
import Foundation
|
import Foundation
|
||||||
import Handler.Apps
|
import Handler.Apps
|
||||||
import Handler.ErrorLogs
|
import Handler.ErrorLogs
|
||||||
import Handler.Icons
|
import Handler.Icons
|
||||||
import Handler.Version
|
|
||||||
import Handler.Marketplace
|
import Handler.Marketplace
|
||||||
|
import Handler.Version
|
||||||
|
import Lib.PkgRepository ( watchPkgRepoRoot )
|
||||||
import Lib.Ssl
|
import Lib.Ssl
|
||||||
|
import Model
|
||||||
|
import Network.HTTP.Types.Header ( hOrigin )
|
||||||
|
import Network.Wai.Middleware.RequestLogger.JSON
|
||||||
import Settings
|
import Settings
|
||||||
|
import System.Directory ( createDirectoryIfMissing )
|
||||||
import System.Posix.Process
|
import System.Posix.Process
|
||||||
import System.Time.Extra
|
import System.Time.Extra
|
||||||
import Model
|
import Yesod
|
||||||
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)
|
|
||||||
|
|
||||||
-- This line actually creates our YesodDispatch instance. It is the second half
|
-- 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
|
-- of the call to mkYesodData which occurs in Foundation.hs. Please see the
|
||||||
@@ -81,35 +114,36 @@ makeFoundation :: AppSettings -> IO RegistryCtx
|
|||||||
makeFoundation appSettings = do
|
makeFoundation appSettings = do
|
||||||
-- Some basic initializations: HTTP connection manager, logger, and static
|
-- Some basic initializations: HTTP connection manager, logger, and static
|
||||||
-- subsite.
|
-- subsite.
|
||||||
appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger
|
appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger
|
||||||
|
|
||||||
appWebServerThreadId <- newEmptyMVar
|
appWebServerThreadId <- newEmptyMVar
|
||||||
appShouldRestartWeb <- newMVar False
|
appShouldRestartWeb <- newMVar False
|
||||||
|
|
||||||
-- We need a log function to create a connection pool. We need a connection
|
-- 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
|
-- 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
|
-- logging function. To get out of this loop, we initially create a
|
||||||
-- temporary foundation without a real connection pool, get a log function
|
-- temporary foundation without a real connection pool, get a log function
|
||||||
-- from there, and then create the real foundation.
|
-- from there, and then create the real foundation.
|
||||||
let mkFoundation appConnPool = RegistryCtx {..}
|
let mkFoundation appConnPool appStopFsNotify = RegistryCtx { .. }
|
||||||
-- The RegistryCtx {..} syntax is an example of record wild cards. For more
|
-- The RegistryCtx {..} syntax is an example of record wild cards. For more
|
||||||
-- information, see:
|
-- information, see:
|
||||||
-- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html
|
-- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html
|
||||||
tempFoundation = mkFoundation $ panic "connPool forced in tempFoundation"
|
tempFoundation =
|
||||||
|
mkFoundation (panic "connPool forced in tempFoundation") (panic "stopFsNotify forced in tempFoundation")
|
||||||
logFunc = messageLoggerSource tempFoundation appLogger
|
logFunc = messageLoggerSource tempFoundation appLogger
|
||||||
|
|
||||||
|
stop <- runLoggingT (runReaderT watchPkgRepoRoot appSettings) logFunc
|
||||||
createDirectoryIfMissing True (errorLogRoot appSettings)
|
createDirectoryIfMissing True (errorLogRoot appSettings)
|
||||||
|
|
||||||
-- Create the database connection pool
|
-- Create the database connection pool
|
||||||
pool <- flip runLoggingT logFunc $ createPostgresqlPool
|
pool <- flip runLoggingT logFunc
|
||||||
(pgConnStr $ appDatabaseConf appSettings)
|
$ createPostgresqlPool (pgConnStr $ appDatabaseConf appSettings) (pgPoolSize . appDatabaseConf $ appSettings)
|
||||||
(pgPoolSize . appDatabaseConf $ appSettings)
|
|
||||||
|
|
||||||
-- Preform database migration using application logging settings
|
-- Preform database migration using application logging settings
|
||||||
runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc
|
runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc
|
||||||
|
|
||||||
-- Return the foundation
|
-- Return the foundation
|
||||||
return $ mkFoundation pool
|
return $ mkFoundation pool stop
|
||||||
|
|
||||||
-- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and
|
-- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and
|
||||||
-- applying some additional middlewares.
|
-- applying some additional middlewares.
|
||||||
@@ -187,14 +221,12 @@ dynamicCorsResourcePolicy req = Just . policy . lookup hOrigin $ requestHeaders
|
|||||||
}
|
}
|
||||||
|
|
||||||
makeLogWare :: RegistryCtx -> IO Middleware
|
makeLogWare :: RegistryCtx -> IO Middleware
|
||||||
makeLogWare foundation =
|
makeLogWare foundation = mkRequestLogger def
|
||||||
mkRequestLogger def
|
{ outputFormat = if appDetailedRequestLogging $ appSettings foundation
|
||||||
{ outputFormat =
|
then Detailed True
|
||||||
if appDetailedRequestLogging $ appSettings foundation
|
else CustomOutputFormatWithDetailsAndHeaders formatAsJSONWithHeaders
|
||||||
then Detailed True
|
, destination = Logger $ loggerSet $ appLogger foundation
|
||||||
else CustomOutputFormatWithDetailsAndHeaders formatAsJSONWithHeaders
|
}
|
||||||
, destination = Logger $ loggerSet $ appLogger foundation
|
|
||||||
}
|
|
||||||
|
|
||||||
makeAuthWare :: RegistryCtx -> Middleware
|
makeAuthWare :: RegistryCtx -> Middleware
|
||||||
makeAuthWare _ app req res = next
|
makeAuthWare _ app req res = next
|
||||||
@@ -227,10 +259,10 @@ appMain = do
|
|||||||
-- Get the settings from all relevant sources
|
-- Get the settings from all relevant sources
|
||||||
settings <- loadYamlSettingsArgs
|
settings <- loadYamlSettingsArgs
|
||||||
-- fall back to compile-time values, set to [] to require values at runtime
|
-- fall back to compile-time values, set to [] to require values at runtime
|
||||||
[configSettingsYmlValue]
|
[configSettingsYmlValue]
|
||||||
|
|
||||||
-- allow environment variables to override
|
-- allow environment variables to override
|
||||||
useEnv
|
useEnv
|
||||||
|
|
||||||
-- Generate the foundation from the settings
|
-- Generate the foundation from the settings
|
||||||
makeFoundation settings >>= startApp
|
makeFoundation settings >>= startApp
|
||||||
@@ -239,36 +271,38 @@ startApp :: RegistryCtx -> IO ()
|
|||||||
startApp foundation = do
|
startApp foundation = do
|
||||||
when (sslAuto . appSettings $ foundation) $ do
|
when (sslAuto . appSettings $ foundation) $ do
|
||||||
-- set up ssl certificates
|
-- set up ssl certificates
|
||||||
putStrLn @Text "Setting up SSL"
|
runLog $ $logInfo "Setting up SSL"
|
||||||
_ <- setupSsl $ appSettings foundation
|
_ <- setupSsl $ appSettings foundation
|
||||||
putStrLn @Text "SSL Setup Complete"
|
runLog $ $logInfo "SSL Setup Complete"
|
||||||
|
|
||||||
-- certbot renew loop
|
-- certbot renew loop
|
||||||
void . forkIO $ forever $ flip runReaderT foundation $ do
|
void . forkIO $ forever $ flip runReaderT foundation $ do
|
||||||
shouldRenew <- doesSslNeedRenew
|
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
|
when shouldRenew $ do
|
||||||
putStrLn @Text "Renewing SSL Certs."
|
runLog $ $logInfo "Renewing SSL Certs."
|
||||||
renewSslCerts
|
renewSslCerts
|
||||||
liftIO $ restartWeb foundation
|
liftIO $ restartWeb foundation
|
||||||
liftIO $ sleep 86_400
|
liftIO $ sleep 86_400
|
||||||
|
|
||||||
startWeb foundation
|
startWeb foundation
|
||||||
|
where
|
||||||
|
runLog :: MonadIO m => LoggingT m a -> m a
|
||||||
|
runLog a = runLoggingT a (messageLoggerSource foundation (appLogger foundation))
|
||||||
|
|
||||||
startWeb :: RegistryCtx -> IO ()
|
startWeb :: RegistryCtx -> IO ()
|
||||||
startWeb foundation = do
|
startWeb foundation = do
|
||||||
app <- makeApplication foundation
|
app <- makeApplication foundation
|
||||||
startWeb' app
|
startWeb' app
|
||||||
where
|
where
|
||||||
startWeb' app = do
|
startWeb' app = (`onException` (appStopFsNotify foundation)) $ do
|
||||||
let AppSettings{..} = appSettings foundation
|
let AppSettings {..} = appSettings foundation
|
||||||
putStrLn @Text $ "Launching Tor Web Server on port " <> show torPort
|
runLog $ $logInfo $ [i|Launching Tor Web Server on port #{torPort}|]
|
||||||
torAction <- async $ runSettings (warpSettings torPort foundation) app
|
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
|
action <- if sslAuto
|
||||||
then async $ runTLS (tlsSettings sslCertLocation sslKeyLocation)
|
then async $ runTLS (tlsSettings sslCertLocation sslKeyLocation) (warpSettings appPort foundation) app
|
||||||
(warpSettings appPort foundation) app
|
else async $ runSettings (warpSettings appPort foundation) app
|
||||||
else async $ runSettings (warpSettings appPort foundation) app
|
|
||||||
let actions = (action, torAction)
|
let actions = (action, torAction)
|
||||||
|
|
||||||
setWebProcessThreadId (join (***) asyncThreadId actions) foundation
|
setWebProcessThreadId (join (***) asyncThreadId actions) foundation
|
||||||
@@ -286,8 +320,9 @@ startWeb foundation = do
|
|||||||
shouldRestart <- takeMVar (appShouldRestartWeb foundation)
|
shouldRestart <- takeMVar (appShouldRestartWeb foundation)
|
||||||
when shouldRestart $ do
|
when shouldRestart $ do
|
||||||
putMVar (appShouldRestartWeb foundation) False
|
putMVar (appShouldRestartWeb foundation) False
|
||||||
putStrLn @Text "Restarting Web Server"
|
runLog $ $logInfo "Restarting Web Server"
|
||||||
startWeb' app
|
startWeb' app
|
||||||
|
runLog a = runLoggingT a (messageLoggerSource foundation (appLogger foundation))
|
||||||
|
|
||||||
restartWeb :: RegistryCtx -> IO ()
|
restartWeb :: RegistryCtx -> IO ()
|
||||||
restartWeb foundation = do
|
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
|
-- Careful, you should always spawn this within forkIO so as to avoid accidentally killing the running process
|
||||||
shutdownWeb :: RegistryCtx -> IO ()
|
shutdownWeb :: RegistryCtx -> IO ()
|
||||||
shutdownWeb RegistryCtx{..} = do
|
shutdownWeb RegistryCtx {..} = do
|
||||||
threadIds <- takeMVar appWebServerThreadId
|
threadIds <- takeMVar appWebServerThreadId
|
||||||
void $ both killThread threadIds
|
void $ both killThread threadIds
|
||||||
|
|
||||||
--------------------------------------------------------------
|
--------------------------------------------------------------
|
||||||
-- Functions for DevelMain.hs (a way to run the RegistryCtx from GHCi)
|
-- Functions for DevelMain.hs (a way to run the RegistryCtx from GHCi)
|
||||||
--------------------------------------------------------------
|
--------------------------------------------------------------
|
||||||
|
|
||||||
getApplicationRepl :: IO (Int, RegistryCtx, Application)
|
getApplicationRepl :: IO (Int, RegistryCtx, Application)
|
||||||
getApplicationRepl = do
|
getApplicationRepl = do
|
||||||
settings <- getAppSettings
|
settings <- getAppSettings
|
||||||
foundation <- getAppSettings >>= makeFoundation
|
foundation <- getAppSettings >>= makeFoundation
|
||||||
wsettings <- getDevSettings $ warpSettings (appPort settings) foundation
|
wsettings <- getDevSettings $ warpSettings (appPort settings) foundation
|
||||||
app1 <- makeApplication foundation
|
app1 <- makeApplication foundation
|
||||||
return (getPort wsettings, foundation, app1)
|
return (getPort wsettings, foundation, app1)
|
||||||
|
|
||||||
shutdownApp :: RegistryCtx -> IO ()
|
shutdownApp :: RegistryCtx -> IO ()
|
||||||
shutdownApp _ = return ()
|
shutdownApp _ = return ()
|
||||||
@@ -323,10 +358,10 @@ shutdownApp _ = return ()
|
|||||||
-- | For yesod devel, return the Warp settings and WAI Application.
|
-- | For yesod devel, return the Warp settings and WAI Application.
|
||||||
getApplicationDev :: AppPort -> IO (Settings, Application)
|
getApplicationDev :: AppPort -> IO (Settings, Application)
|
||||||
getApplicationDev port = do
|
getApplicationDev port = do
|
||||||
settings <- getAppSettings
|
settings <- getAppSettings
|
||||||
foundation <- makeFoundation settings
|
foundation <- makeFoundation settings
|
||||||
app <- makeApplication foundation
|
app <- makeApplication foundation
|
||||||
wsettings <- getDevSettings $ warpSettings port foundation
|
wsettings <- getDevSettings $ warpSettings port foundation
|
||||||
return (wsettings, app)
|
return (wsettings, app)
|
||||||
|
|
||||||
-- | main function for use by yesod devel
|
-- | main function for use by yesod devel
|
||||||
@@ -342,3 +377,7 @@ develMain = do
|
|||||||
-- | Run a handler
|
-- | Run a handler
|
||||||
handler :: Handler a -> IO a
|
handler :: Handler a -> IO a
|
||||||
handler h = getAppSettings >>= makeFoundation >>= flip unsafeHandler h
|
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 ^. SAppDescShort `ilike` (%) ++. val query ++. (%))
|
||||||
||. (service ^. SAppDescLong `ilike` (%) ++. val query ++. (%))
|
||. (service ^. SAppDescLong `ilike` (%) ++. val query ++. (%))
|
||||||
||. (service ^. SAppTitle `ilike` (%) ++. val query ++. (%))
|
||. (service ^. SAppTitle `ilike` (%) ++. val query ++. (%))
|
||||||
||. (service ^. SAppAppId `ilike` (%) ++. val query ++. (%))
|
|
||||||
)
|
)
|
||||||
orderBy [desc (service ^. SAppUpdatedAt)]
|
orderBy [desc (service ^. SAppUpdatedAt)]
|
||||||
limit pageItems
|
limit pageItems
|
||||||
@@ -46,7 +45,6 @@ searchServices (Just category) pageItems offset' query = select $ do
|
|||||||
&&. ( (service ^. SAppDescShort `ilike` (%) ++. val query ++. (%))
|
&&. ( (service ^. SAppDescShort `ilike` (%) ++. val query ++. (%))
|
||||||
||. (service ^. SAppDescLong `ilike` (%) ++. val query ++. (%))
|
||. (service ^. SAppDescLong `ilike` (%) ++. val query ++. (%))
|
||||||
||. (service ^. SAppTitle `ilike` (%) ++. val query ++. (%))
|
||. (service ^. SAppTitle `ilike` (%) ++. val query ++. (%))
|
||||||
||. (service ^. SAppAppId `ilike` (%) ++. val query ++. (%))
|
|
||||||
)
|
)
|
||||||
pure service
|
pure service
|
||||||
)
|
)
|
||||||
|
|||||||
@@ -4,20 +4,20 @@
|
|||||||
|
|
||||||
module Database.Queries where
|
module Database.Queries where
|
||||||
|
|
||||||
import Startlude
|
|
||||||
import Database.Persist.Sql
|
import Database.Persist.Sql
|
||||||
import Lib.Types.AppIndex
|
import Lib.Types.AppIndex
|
||||||
import Lib.Types.Emver
|
import Lib.Types.Emver
|
||||||
import Model
|
import Model
|
||||||
import Orphans.Emver ( )
|
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] []
|
fetchApp appId = selectFirst [SAppAppId ==. appId] []
|
||||||
|
|
||||||
fetchAppVersion :: MonadIO m => Version -> Key SApp -> ReaderT SqlBackend m (Maybe (Entity SVersion))
|
fetchAppVersion :: MonadIO m => Version -> Key SApp -> ReaderT SqlBackend m (Maybe (Entity SVersion))
|
||||||
fetchAppVersion appVersion appId = selectFirst [SVersionNumber ==. appVersion, SVersionAppId ==. appId] []
|
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
|
createApp appId StoreApp {..} = do
|
||||||
time <- liftIO getCurrentTime
|
time <- liftIO getCurrentTime
|
||||||
insertUnique $ SApp time Nothing storeAppTitle appId storeAppDescShort storeAppDescLong storeAppIconType
|
insertUnique $ SApp time Nothing storeAppTitle appId storeAppDescShort storeAppDescLong storeAppIconType
|
||||||
|
|||||||
@@ -2,21 +2,45 @@
|
|||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
{-# LANGUAGE RankNTypes #-}
|
{-# LANGUAGE RankNTypes #-}
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
{-# LANGUAGE ViewPatterns #-}
|
{-# LANGUAGE ViewPatterns #-}
|
||||||
|
{-# LANGUAGE TypeApplications #-}
|
||||||
module Foundation where
|
module Foundation where
|
||||||
|
|
||||||
import Startlude hiding ( Handler )
|
import Startlude hiding ( Handler )
|
||||||
|
|
||||||
import Control.Monad.Logger ( LogSource )
|
import Control.Monad.Logger ( Loc
|
||||||
import Database.Persist.Sql
|
, LogSource
|
||||||
|
, LogStr
|
||||||
|
, ToLogStr(toLogStr)
|
||||||
|
, fromLogStr
|
||||||
|
)
|
||||||
|
import Database.Persist.Sql hiding ( update )
|
||||||
import Lib.Registry
|
import Lib.Registry
|
||||||
import Yesod.Core
|
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 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 Lib.Types.AppIndex
|
||||||
import Settings
|
import Settings
|
||||||
|
import System.Console.ANSI.Codes ( Color(..)
|
||||||
|
, ColorIntensity(..)
|
||||||
|
, ConsoleLayer(Foreground)
|
||||||
|
, SGR(SetColor)
|
||||||
|
)
|
||||||
|
import System.FilePath ( (</>) )
|
||||||
import Yesod.Persist.Core
|
import Yesod.Persist.Core
|
||||||
|
|
||||||
-- | The foundation datatype for your application. This can be a good place to
|
-- | The foundation datatype for your application. This can be a good place to
|
||||||
@@ -31,7 +55,24 @@ data RegistryCtx = RegistryCtx
|
|||||||
, appWebServerThreadId :: MVar (ThreadId, ThreadId)
|
, appWebServerThreadId :: MVar (ThreadId, ThreadId)
|
||||||
, appShouldRestartWeb :: MVar Bool
|
, appShouldRestartWeb :: MVar Bool
|
||||||
, appConnPool :: ConnectionPool
|
, 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 :: (ThreadId, ThreadId) -> RegistryCtx -> IO ()
|
||||||
setWebProcessThreadId tid a = putMVar (appWebServerThreadId a) $ tid
|
setWebProcessThreadId tid a = putMVar (appWebServerThreadId a) $ tid
|
||||||
@@ -78,6 +119,42 @@ instance Yesod RegistryCtx where
|
|||||||
makeLogger :: RegistryCtx -> IO Logger
|
makeLogger :: RegistryCtx -> IO Logger
|
||||||
makeLogger = return . appLogger
|
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.
|
-- How to run database actions.
|
||||||
instance YesodPersist RegistryCtx where
|
instance YesodPersist RegistryCtx where
|
||||||
type YesodPersistBackend RegistryCtx = SqlBackend
|
type YesodPersistBackend RegistryCtx = SqlBackend
|
||||||
|
|||||||
@@ -11,37 +11,58 @@ module Handler.Apps where
|
|||||||
|
|
||||||
import Startlude hiding ( Handler )
|
import Startlude hiding ( Handler )
|
||||||
|
|
||||||
import Control.Monad.Logger
|
import Control.Monad.Logger ( logError
|
||||||
import Data.Aeson
|
, logInfo
|
||||||
|
)
|
||||||
|
import Data.Aeson ( ToJSON
|
||||||
|
, encode
|
||||||
|
)
|
||||||
import qualified Data.Attoparsec.Text as Atto
|
import qualified Data.Attoparsec.Text as Atto
|
||||||
import qualified Data.ByteString.Lazy as BS
|
import qualified Data.ByteString.Lazy as BS
|
||||||
import Data.Conduit
|
|
||||||
import qualified Data.Conduit.Binary as CB
|
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import Database.Persist
|
import Database.Persist ( Entity(entityKey) )
|
||||||
import qualified GHC.Show ( Show(..) )
|
import qualified GHC.Show ( Show(..) )
|
||||||
import Network.HTTP.Types
|
import Network.HTTP.Types ( status404 )
|
||||||
import System.Directory
|
|
||||||
import System.FilePath ( (<.>)
|
import System.FilePath ( (<.>)
|
||||||
, (</>)
|
, takeBaseName
|
||||||
)
|
)
|
||||||
import System.Posix.Files ( fileSize
|
import Yesod.Core ( TypedContent
|
||||||
, getFileStatus
|
, addHeader
|
||||||
|
, notFound
|
||||||
|
, respondSource
|
||||||
|
, sendChunkBS
|
||||||
|
, sendResponseStatus
|
||||||
|
, typeJson
|
||||||
|
, typeOctet
|
||||||
|
, waiRequest
|
||||||
)
|
)
|
||||||
import Yesod.Core
|
import Yesod.Persist.Core ( YesodPersist(runDB) )
|
||||||
import Yesod.Persist.Core
|
|
||||||
|
|
||||||
import Foundation
|
import Conduit ( (.|)
|
||||||
import Lib.Registry
|
, awaitForever
|
||||||
import Lib.Types.AppIndex
|
)
|
||||||
import Lib.Types.Emver
|
import Data.String.Interpolate.IsString
|
||||||
import Lib.Types.FileSystem
|
( i )
|
||||||
import Lib.Error
|
import Database.Queries ( createMetric
|
||||||
import Lib.External.AppMgr
|
, fetchApp
|
||||||
import Settings
|
, fetchAppVersion
|
||||||
import Database.Queries
|
)
|
||||||
|
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 Network.Wai ( Request(requestHeaderUserAgent) )
|
||||||
import Util.Shared
|
import Util.Shared ( addPackageHeader
|
||||||
|
, getVersionSpecFromQuery
|
||||||
|
, orThrow
|
||||||
|
)
|
||||||
|
|
||||||
pureLog :: Show a => a -> Handler a
|
pureLog :: Show a => a -> Handler a
|
||||||
pureLog = liftA2 (*>) ($logInfo . show) pure
|
pureLog = liftA2 (*>) ($logInfo . show) pure
|
||||||
@@ -65,94 +86,42 @@ getEmbassyOsVersion = userAgentOsVersion
|
|||||||
userAgentOsVersion =
|
userAgentOsVersion =
|
||||||
(hush . Atto.parseOnly userAgentOsVersionParser . decodeUtf8 <=< requestHeaderUserAgent) <$> waiRequest
|
(hush . Atto.parseOnly userAgentOsVersionParser . decodeUtf8 <=< requestHeaderUserAgent) <$> waiRequest
|
||||||
|
|
||||||
getSysR :: Extension "" -> Handler TypedContent
|
getAppManifestR :: PkgId -> Handler TypedContent
|
||||||
getSysR e = do
|
getAppManifestR pkg = do
|
||||||
sysResourceDir <- (</> "sys") . resourcesDir . appSettings <$> getYesod
|
versionSpec <- getVersionSpecFromQuery
|
||||||
-- @TODO update with new response type here
|
version <- getBestVersion pkg versionSpec
|
||||||
getApp sysResourceDir e
|
`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
|
getAppR :: S9PK -> Handler TypedContent
|
||||||
getAppManifestR appId = do
|
getAppR file = do
|
||||||
(appsDir, appMgrDir) <- getsYesod $ ((</> "apps") . resourcesDir &&& staticBinDir) . appSettings
|
let pkg = PkgId . T.pack $ takeBaseName (show file)
|
||||||
av <- getVersionFromQuery appsDir appExt >>= \case
|
versionSpec <- getVersionSpecFromQuery
|
||||||
Nothing -> sendResponseStatus status404 ("Specified App Version Not Found" :: Text)
|
version <- getBestVersion pkg versionSpec
|
||||||
Just v -> pure v
|
`orThrow` sendResponseStatus status404 (NotFoundE [i|#{pkg} satisfying #{versionSpec}|])
|
||||||
let appDir = (<> "/") . (</> show av) . (</> toS appId) $ appsDir
|
addPackageHeader pkg version
|
||||||
manifest <- handleS9ErrT $ getManifest appMgrDir appDir appExt
|
void $ recordMetrics pkg version
|
||||||
addPackageHeader appMgrDir appDir appExt
|
(len, src) <- getPackage pkg version
|
||||||
pure $ TypedContent "application/json" (toContent manifest)
|
addHeader "Content-Length" (show len)
|
||||||
where appExt = Extension (toS appId) :: Extension "s9pk"
|
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
|
recordMetrics :: PkgId -> Version -> Handler ()
|
||||||
getAppR e = do
|
recordMetrics pkg appVersion = do
|
||||||
appResourceDir <- (</> "apps") . resourcesDir . appSettings <$> getYesod
|
sa <- runDB $ fetchApp $ pkg
|
||||||
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'
|
|
||||||
case sa of
|
case sa of
|
||||||
Nothing -> do
|
Nothing -> do
|
||||||
$logError $ appId' <> " not found in database"
|
$logError $ [i|#{pkg} not found in database|]
|
||||||
notFound
|
notFound
|
||||||
Just a -> do
|
Just a -> do
|
||||||
let appKey' = entityKey a
|
let appKey' = entityKey a
|
||||||
existingVersion <- runDB $ fetchAppVersion appVersion appKey'
|
existingVersion <- runDB $ fetchAppVersion appVersion appKey'
|
||||||
case existingVersion of
|
case existingVersion of
|
||||||
Nothing -> do
|
Nothing -> do
|
||||||
$logError $ "Version: " <> show appVersion <> " not found in database"
|
$logError $ [i|#{pkg}@#{appVersion} not found in database|]
|
||||||
notFound
|
notFound
|
||||||
Just v -> runDB $ createMetric (entityKey a) (entityKey v)
|
Just v -> runDB $ createMetric (entityKey a) (entityKey v)
|
||||||
|
|
||||||
|
|||||||
@@ -2,6 +2,7 @@
|
|||||||
{-# LANGUAGE TypeApplications #-}
|
{-# LANGUAGE TypeApplications #-}
|
||||||
{-# LANGUAGE RecordWildCards #-}
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
{-# LANGUAGE DeriveGeneric #-}
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
|
||||||
@@ -9,19 +10,22 @@ module Handler.Icons where
|
|||||||
|
|
||||||
import Startlude hiding ( Handler )
|
import Startlude hiding ( Handler )
|
||||||
|
|
||||||
import Yesod.Core
|
import Data.Conduit ( (.|)
|
||||||
|
, awaitForever
|
||||||
import Data.Aeson
|
)
|
||||||
import qualified Data.ByteString.Lazy as BS
|
import Data.String.Interpolate.IsString
|
||||||
|
( i )
|
||||||
import Foundation
|
import Foundation
|
||||||
import Lib.Error
|
import Lib.Error ( S9Error(NotFoundE) )
|
||||||
import Lib.External.AppMgr
|
import Lib.PkgRepository ( getBestVersion
|
||||||
import Lib.Registry
|
, getIcon
|
||||||
|
, getInstructions
|
||||||
|
, getLicense
|
||||||
|
)
|
||||||
import Lib.Types.AppIndex
|
import Lib.Types.AppIndex
|
||||||
import Network.HTTP.Types
|
import Network.HTTP.Types
|
||||||
import Settings
|
|
||||||
import System.FilePath.Posix
|
|
||||||
import Util.Shared
|
import Util.Shared
|
||||||
|
import Yesod.Core
|
||||||
|
|
||||||
data IconType = PNG | JPG | JPEG | SVG
|
data IconType = PNG | JPG | JPEG | SVG
|
||||||
deriving (Eq, Show, Generic, Read)
|
deriving (Eq, Show, Generic, Read)
|
||||||
@@ -33,62 +37,29 @@ instance FromJSON IconType
|
|||||||
ixt :: Text
|
ixt :: Text
|
||||||
ixt = toS $ toUpper <$> drop 1 ".png"
|
ixt = toS $ toUpper <$> drop 1 ".png"
|
||||||
|
|
||||||
getIconsR :: AppIdentifier -> Handler TypedContent
|
getIconsR :: PkgId -> Handler TypedContent
|
||||||
getIconsR appId = do
|
getIconsR pkg = do
|
||||||
(appsDir, appMgrDir) <- getsYesod $ ((</> "apps") . resourcesDir &&& staticBinDir) . appSettings
|
spec <- getVersionSpecFromQuery
|
||||||
spec <- getVersionFromQuery appsDir ext >>= \case
|
version <- getBestVersion pkg spec
|
||||||
Nothing -> sendResponseStatus status404 ("Specified App Version Not Found" :: Text)
|
`orThrow` sendResponseStatus status400 (NotFoundE [i|Icon for #{pkg} satisfying #{spec}|])
|
||||||
Just v -> pure v
|
(ct, len, src) <- getIcon pkg version
|
||||||
let appDir = (<> "/") . (</> show spec) . (</> toS appId) $ appsDir
|
addHeader "Content-Length" (show len)
|
||||||
manifest' <- handleS9ErrT $ getManifest appMgrDir appDir ext
|
respondSource ct $ src .| awaitForever sendChunkBS
|
||||||
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"
|
|
||||||
|
|
||||||
getLicenseR :: AppIdentifier -> Handler TypedContent
|
getLicenseR :: PkgId -> Handler TypedContent
|
||||||
getLicenseR appId = do
|
getLicenseR pkg = do
|
||||||
(appsDir, appMgrDir) <- getsYesod $ ((</> "apps") . resourcesDir &&& staticBinDir) . appSettings
|
spec <- getVersionSpecFromQuery
|
||||||
spec <- getVersionFromQuery appsDir ext >>= \case
|
version <- getBestVersion pkg spec
|
||||||
Nothing -> sendResponseStatus status404 ("Specified App Version Not Found" :: Text)
|
`orThrow` sendResponseStatus status400 (NotFoundE [i|License for #{pkg} satisfying #{spec}|])
|
||||||
Just v -> pure v
|
(len, src) <- getLicense pkg version
|
||||||
servicePath <- liftIO $ getVersionedFileFromDir appsDir ext spec
|
addHeader "Content-Length" (show len)
|
||||||
case servicePath of
|
respondSource typePlain $ src .| awaitForever sendChunkBS
|
||||||
Nothing -> notFound
|
|
||||||
Just p -> do
|
|
||||||
respondSource typePlain (sendChunkBS =<< handleS9ErrT (getLicense appMgrDir p ext))
|
|
||||||
where ext = Extension (toS appId) :: Extension "s9pk"
|
|
||||||
|
|
||||||
getInstructionsR :: AppIdentifier -> Handler TypedContent
|
getInstructionsR :: PkgId -> Handler TypedContent
|
||||||
getInstructionsR appId = do
|
getInstructionsR pkg = do
|
||||||
(appsDir, appMgrDir) <- getsYesod $ ((</> "apps") . resourcesDir &&& staticBinDir) . appSettings
|
spec <- getVersionSpecFromQuery
|
||||||
spec <- getVersionFromQuery appsDir ext >>= \case
|
version <- getBestVersion pkg spec
|
||||||
Nothing -> sendResponseStatus status404 ("Specified App Version Not Found" :: Text)
|
`orThrow` sendResponseStatus status400 (NotFoundE [i|Instructions for #{pkg} satisfying #{spec}|])
|
||||||
Just v -> pure v
|
(len, src) <- getInstructions pkg version
|
||||||
servicePath <- liftIO $ getVersionedFileFromDir appsDir ext spec
|
addHeader "Content-Length" (show len)
|
||||||
case servicePath of
|
respondSource typePlain $ src .| awaitForever sendChunkBS
|
||||||
Nothing -> notFound
|
|
||||||
Just p -> do
|
|
||||||
respondSource typePlain (sendChunkBS =<< handleS9ErrT (getInstructions appMgrDir p ext))
|
|
||||||
where ext = Extension (toS appId) :: Extension "s9pk"
|
|
||||||
|
|||||||
@@ -7,39 +7,135 @@
|
|||||||
{-# LANGUAGE DeriveGeneric #-}
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
{-# LANGUAGE QuasiQuotes #-}
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
{-# LANGUAGE TupleSections #-}
|
{-# LANGUAGE TupleSections #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE DeriveAnyClass #-}
|
||||||
|
|
||||||
module Handler.Marketplace where
|
module Handler.Marketplace where
|
||||||
import Startlude hiding ( from
|
|
||||||
, Handler
|
import Startlude hiding ( Handler
|
||||||
|
, from
|
||||||
, on
|
, on
|
||||||
, sortOn
|
, 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 {
|
newtype CategoryRes = CategoryRes {
|
||||||
categories :: [CategoryTitle]
|
categories :: [CategoryTitle]
|
||||||
} deriving (Show, Generic)
|
} deriving (Show, Generic)
|
||||||
@@ -49,15 +145,16 @@ instance ToContent CategoryRes where
|
|||||||
toContent = toContent . toJSON
|
toContent = toContent . toJSON
|
||||||
instance ToTypedContent CategoryRes where
|
instance ToTypedContent CategoryRes where
|
||||||
toTypedContent = toTypedContent . toJSON
|
toTypedContent = toTypedContent . toJSON
|
||||||
data ServiceRes = ServiceRes
|
data ServiceRes = ServiceRes
|
||||||
{ serviceResIcon :: URL
|
{ serviceResIcon :: URL
|
||||||
, serviceResManifest :: Maybe Data.Aeson.Value -- ServiceManifest
|
, serviceResManifest :: Data.Aeson.Value -- ServiceManifest
|
||||||
, serviceResCategories :: [CategoryTitle]
|
, serviceResCategories :: [CategoryTitle]
|
||||||
, serviceResInstructions :: URL
|
, serviceResInstructions :: URL
|
||||||
, serviceResLicense :: URL
|
, serviceResLicense :: URL
|
||||||
, serviceResVersions :: [Version]
|
, serviceResVersions :: [Version]
|
||||||
, serviceResDependencyInfo :: HM.HashMap AppIdentifier DependencyInfo
|
, serviceResDependencyInfo :: HM.HashMap PkgId DependencyInfo
|
||||||
} deriving (Generic)
|
}
|
||||||
|
deriving Generic
|
||||||
|
|
||||||
newtype ReleaseNotes = ReleaseNotes { unReleaseNotes :: HM.HashMap Version Text }
|
newtype ReleaseNotes = ReleaseNotes { unReleaseNotes :: HM.HashMap Version Text }
|
||||||
deriving (Eq, Show)
|
deriving (Eq, Show)
|
||||||
@@ -82,16 +179,18 @@ instance ToContent ServiceRes where
|
|||||||
instance ToTypedContent ServiceRes where
|
instance ToTypedContent ServiceRes where
|
||||||
toTypedContent = toTypedContent . toJSON
|
toTypedContent = toTypedContent . toJSON
|
||||||
data DependencyInfo = DependencyInfo
|
data DependencyInfo = DependencyInfo
|
||||||
{ dependencyInfoTitle :: Text -- title
|
{ dependencyInfoTitle :: PkgId
|
||||||
, dependencyInfoIcon :: Text -- url
|
, dependencyInfoIcon :: URL
|
||||||
} deriving (Eq, Show)
|
}
|
||||||
|
deriving (Eq, Show)
|
||||||
instance ToJSON DependencyInfo where
|
instance ToJSON DependencyInfo where
|
||||||
toJSON DependencyInfo {..} = object ["icon" .= dependencyInfoIcon, "title" .= dependencyInfoTitle]
|
toJSON DependencyInfo {..} = object ["icon" .= dependencyInfoIcon, "title" .= dependencyInfoTitle]
|
||||||
|
|
||||||
data ServiceListRes = ServiceListRes {
|
data ServiceListRes = ServiceListRes
|
||||||
serviceListResCategories :: [CategoryTitle]
|
{ serviceListResCategories :: [CategoryTitle]
|
||||||
, serviceListResServices :: [ServiceAvailable]
|
, serviceListResServices :: [ServiceAvailable]
|
||||||
} deriving (Show)
|
}
|
||||||
|
deriving Show
|
||||||
instance ToJSON ServiceListRes where
|
instance ToJSON ServiceListRes where
|
||||||
toJSON ServiceListRes {..} =
|
toJSON ServiceListRes {..} =
|
||||||
object ["categories" .= serviceListResCategories, "services" .= serviceListResServices]
|
object ["categories" .= serviceListResCategories, "services" .= serviceListResServices]
|
||||||
@@ -101,12 +200,13 @@ instance ToTypedContent ServiceListRes where
|
|||||||
toTypedContent = toTypedContent . toJSON
|
toTypedContent = toTypedContent . toJSON
|
||||||
|
|
||||||
data ServiceAvailable = ServiceAvailable
|
data ServiceAvailable = ServiceAvailable
|
||||||
{ serviceAvailableId :: Text
|
{ serviceAvailableId :: PkgId
|
||||||
, serviceAvailableTitle :: Text
|
, serviceAvailableTitle :: Text
|
||||||
, serviceAvailableVersion :: Version
|
, serviceAvailableVersion :: Version
|
||||||
, serviceAvailableIcon :: URL
|
, serviceAvailableIcon :: URL
|
||||||
, serviceAvailableDescShort :: Text
|
, serviceAvailableDescShort :: Text
|
||||||
} deriving (Show)
|
}
|
||||||
|
deriving Show
|
||||||
instance ToJSON ServiceAvailable where
|
instance ToJSON ServiceAvailable where
|
||||||
toJSON ServiceAvailable {..} = object
|
toJSON ServiceAvailable {..} = object
|
||||||
[ "id" .= serviceAvailableId
|
[ "id" .= serviceAvailableId
|
||||||
@@ -128,7 +228,7 @@ instance ToContent ServiceAvailableRes where
|
|||||||
instance ToTypedContent ServiceAvailableRes where
|
instance ToTypedContent ServiceAvailableRes where
|
||||||
toTypedContent = toTypedContent . toJSON
|
toTypedContent = toTypedContent . toJSON
|
||||||
|
|
||||||
newtype VersionLatestRes = VersionLatestRes (HM.HashMap AppIdentifier (Maybe Version))
|
newtype VersionLatestRes = VersionLatestRes (HM.HashMap PkgId (Maybe Version))
|
||||||
deriving (Show, Generic)
|
deriving (Show, Generic)
|
||||||
instance ToJSON VersionLatestRes
|
instance ToJSON VersionLatestRes
|
||||||
instance ToContent VersionLatestRes where
|
instance ToContent VersionLatestRes where
|
||||||
@@ -138,18 +238,19 @@ instance ToTypedContent VersionLatestRes where
|
|||||||
data OrderArrangement = ASC | DESC
|
data OrderArrangement = ASC | DESC
|
||||||
deriving (Eq, Show, Read)
|
deriving (Eq, Show, Read)
|
||||||
data ServiceListDefaults = ServiceListDefaults
|
data ServiceListDefaults = ServiceListDefaults
|
||||||
{ serviceListOrder :: OrderArrangement
|
{ serviceListOrder :: OrderArrangement
|
||||||
, serviceListPageLimit :: Int64 -- the number of items per page
|
, serviceListPageLimit :: Int64 -- the number of items per page
|
||||||
, serviceListPageNumber :: Int64 -- the page you are on
|
, serviceListPageNumber :: Int64 -- the page you are on
|
||||||
, serviceListCategory :: Maybe CategoryTitle
|
, serviceListCategory :: Maybe CategoryTitle
|
||||||
, serviceListQuery :: Text
|
, serviceListQuery :: Text
|
||||||
}
|
}
|
||||||
deriving (Eq, Show, Read)
|
deriving (Eq, Show, Read)
|
||||||
data EosRes = EosRes
|
data EosRes = EosRes
|
||||||
{ eosResVersion :: Version
|
{ eosResVersion :: Version
|
||||||
, eosResHeadline :: Text
|
, eosResHeadline :: Text
|
||||||
, eosResReleaseNotes :: ReleaseNotes
|
, eosResReleaseNotes :: ReleaseNotes
|
||||||
} deriving (Eq, Show, Generic)
|
}
|
||||||
|
deriving (Eq, Show, Generic)
|
||||||
instance ToJSON EosRes where
|
instance ToJSON EosRes where
|
||||||
toJSON EosRes {..} =
|
toJSON EosRes {..} =
|
||||||
object ["version" .= eosResVersion, "headline" .= eosResHeadline, "release-notes" .= eosResReleaseNotes]
|
object ["version" .= eosResVersion, "headline" .= eosResHeadline, "release-notes" .= eosResReleaseNotes]
|
||||||
@@ -159,9 +260,10 @@ instance ToTypedContent EosRes where
|
|||||||
toTypedContent = toTypedContent . toJSON
|
toTypedContent = toTypedContent . toJSON
|
||||||
|
|
||||||
data PackageVersion = PackageVersion
|
data PackageVersion = PackageVersion
|
||||||
{ packageVersionId :: AppIdentifier
|
{ packageVersionId :: PkgId
|
||||||
, packageVersionVersion :: VersionRange
|
, packageVersionVersion :: VersionRange
|
||||||
} deriving (Show)
|
}
|
||||||
|
deriving Show
|
||||||
instance FromJSON PackageVersion where
|
instance FromJSON PackageVersion where
|
||||||
parseJSON = withObject "package version" $ \o -> do
|
parseJSON = withObject "package version" $ \o -> do
|
||||||
packageVersionId <- o .: "id"
|
packageVersionId <- o .: "id"
|
||||||
@@ -176,8 +278,8 @@ getCategoriesR = do
|
|||||||
pure cats
|
pure cats
|
||||||
pure $ CategoryRes $ categoryName . entityVal <$> allCategories
|
pure $ CategoryRes $ categoryName . entityVal <$> allCategories
|
||||||
|
|
||||||
getEosR :: Handler EosRes
|
getEosVersionR :: Handler EosRes
|
||||||
getEosR = do
|
getEosVersionR = do
|
||||||
allEosVersions <- runDB $ select $ do
|
allEosVersions <- runDB $ select $ do
|
||||||
vers <- from $ table @OsVersion
|
vers <- from $ table @OsVersion
|
||||||
orderBy [desc (vers ^. OsVersionCreatedAt)]
|
orderBy [desc (vers ^. OsVersionCreatedAt)]
|
||||||
@@ -199,159 +301,188 @@ getReleaseNotesR :: Handler ReleaseNotes
|
|||||||
getReleaseNotesR = do
|
getReleaseNotesR = do
|
||||||
getParameters <- reqGetParams <$> getRequest
|
getParameters <- reqGetParams <$> getRequest
|
||||||
case lookup "id" getParameters of
|
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
|
Just package -> do
|
||||||
(service, _ ) <- runDB $ fetchLatestApp package >>= errOnNothing status404 "package not found"
|
(service, _) <- runDB $ fetchLatestApp (PkgId package) `orThrow` sendResponseStatus
|
||||||
(_ , mappedVersions) <- fetchAllAppVersions (entityKey service)
|
status404
|
||||||
|
(NotFoundE $ show package)
|
||||||
|
(_, mappedVersions) <- fetchAllAppVersions (entityKey service)
|
||||||
pure mappedVersions
|
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 :: Handler VersionLatestRes
|
||||||
getVersionLatestR = do
|
getVersionLatestR = do
|
||||||
getParameters <- reqGetParams <$> getRequest
|
getParameters <- reqGetParams <$> getRequest
|
||||||
case lookup "ids" getParameters of
|
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
|
Just packages -> case eitherDecode $ BS.fromStrict $ encodeUtf8 packages of
|
||||||
Left e -> sendResponseStatus status400 ("could not parse query param \"ids\"" <> show e :: Text)
|
Left _ -> sendResponseStatus status400 (InvalidParamsE "get:ids" packages)
|
||||||
Right (p :: [AppIdentifier]) -> do
|
Right (p :: [PkgId]) -> do
|
||||||
let packageList :: [(AppIdentifier, Maybe Version)] = (, Nothing) <$> p
|
let packageList :: [(PkgId, Maybe Version)] = (, Nothing) <$> p
|
||||||
found <- runDB $ traverse fetchLatestApp $ fst <$> packageList
|
found <- runDB $ traverse fetchLatestApp $ fst <$> packageList
|
||||||
pure
|
pure
|
||||||
$ VersionLatestRes
|
$ VersionLatestRes
|
||||||
$ HM.union
|
$ HM.union
|
||||||
( HM.fromList
|
( HM.fromList
|
||||||
$ (\v ->
|
$ (\v -> (sAppAppId $ entityVal $ fst v, Just $ sVersionNumber $ entityVal $ snd v))
|
||||||
( sAppAppId $ entityVal $ fst v :: AppIdentifier
|
|
||||||
, Just $ sVersionNumber $ entityVal $ snd v
|
|
||||||
)
|
|
||||||
)
|
|
||||||
<$> catMaybes found
|
<$> catMaybes found
|
||||||
)
|
)
|
||||||
$ HM.fromList packageList
|
$ HM.fromList packageList
|
||||||
|
|
||||||
getPackageListR :: Handler ServiceAvailableRes
|
getPackageListR :: Handler ServiceAvailableRes
|
||||||
getPackageListR = do
|
getPackageListR = do
|
||||||
getParameters <- reqGetParams <$> getRequest
|
pkgIds <- getPkgIdsQuery
|
||||||
let defaults = ServiceListDefaults { serviceListOrder = DESC
|
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
|
, serviceListPageLimit = 20
|
||||||
, serviceListPageNumber = 1
|
, serviceListPageNumber = 1
|
||||||
, serviceListCategory = Nothing
|
, serviceListCategory = Nothing
|
||||||
, serviceListQuery = ""
|
, serviceListQuery = ""
|
||||||
}
|
}
|
||||||
case lookup "ids" getParameters of
|
getPkgIdsQuery :: Handler (Maybe [PackageVersion])
|
||||||
Nothing -> do
|
getPkgIdsQuery = lookupGetParam "ids" >>= \case
|
||||||
-- query for all
|
Nothing -> pure Nothing
|
||||||
category <- case lookup "category" getParameters of
|
Just ids -> case eitherDecodeStrict (encodeUtf8 ids) of
|
||||||
Nothing -> pure $ serviceListCategory defaults
|
Left _ -> do
|
||||||
Just c -> case readMaybe $ T.toUpper c of
|
let e = InvalidParamsE "get:ids" ids
|
||||||
Nothing -> do
|
$logWarn (show e)
|
||||||
$logInfo c
|
sendResponseStatus status400 e
|
||||||
sendResponseStatus status400 ("could not read category" :: Text)
|
Right a -> pure a
|
||||||
Just t -> pure $ Just t
|
getCategoryQuery :: Handler (Maybe CategoryTitle)
|
||||||
page <- case lookup "page" getParameters of
|
getCategoryQuery = lookupGetParam "category" >>= \case
|
||||||
Nothing -> pure $ serviceListPageNumber defaults
|
Nothing -> pure Nothing
|
||||||
Just p -> case readMaybe p of
|
Just c -> case readMaybe . T.toUpper $ c of
|
||||||
Nothing -> do
|
Nothing -> do
|
||||||
$logInfo p
|
let e = InvalidParamsE "get:category" c
|
||||||
sendResponseStatus status400 ("could not read page" :: Text)
|
$logWarn (show e)
|
||||||
Just t -> pure $ case t of
|
sendResponseStatus status400 e
|
||||||
0 -> 1 -- disallow page 0 so offset is not negative
|
Just t -> pure $ Just t
|
||||||
_ -> t
|
getPageQuery :: Handler Int64
|
||||||
limit' <- case lookup "per-page" getParameters of
|
getPageQuery = lookupGetParam "page" >>= \case
|
||||||
Nothing -> pure $ serviceListPageLimit defaults
|
Nothing -> pure $ serviceListPageNumber defaults
|
||||||
Just c -> case readMaybe $ toS c of
|
Just p -> case readMaybe p of
|
||||||
Nothing -> sendResponseStatus status400 ("could not read per-page" :: Text)
|
Nothing -> do
|
||||||
Just l -> pure l
|
let e = InvalidParamsE "get:page" p
|
||||||
query <- T.filter (not . isSpace) . fromMaybe (serviceListQuery defaults) <$> lookupGetParam "query"
|
$logWarn (show e)
|
||||||
filteredServices <- runDB $ searchServices category limit' ((page - 1) * limit') query
|
sendResponseStatus status400 e
|
||||||
-- domain <- getsYesod $ registryHostname . appSettings
|
Just t -> pure $ case t of
|
||||||
-- (appsDir, appMgrDir) <- getsYesod $ ((</> "apps") . resourcesDir &&& staticBinDir) . appSettings
|
0 -> 1 -- disallow page 0 so offset is not negative
|
||||||
-- res <- runDB $ traverse (mapEntityToServiceAvailable appMgrDir appsDir domain) filteredServices
|
_ -> t
|
||||||
res <- traverse (getServiceDetails Nothing) filteredServices
|
getLimitQuery :: Handler Int64
|
||||||
pure $ ServiceAvailableRes res
|
getLimitQuery = lookupGetParam "per-page" >>= \case
|
||||||
|
Nothing -> pure $ serviceListPageLimit defaults
|
||||||
Just packageVersionList -> case eitherDecode $ BS.fromStrict $ encodeUtf8 packageVersionList of
|
Just pp -> case readMaybe pp of
|
||||||
Left e -> sendResponseStatus status400 ("could not parse query param \"ids\"" <> show e :: Text)
|
Nothing -> do
|
||||||
Right (packages :: [PackageVersion]) -> do
|
let e = InvalidParamsE "get:per-page" pp
|
||||||
-- for each item in list get best available from version range
|
$logWarn (show e)
|
||||||
availableServices <- traverse getPackageDetails packages
|
sendResponseStatus status400 e
|
||||||
services <- traverse (uncurry getServiceDetails) availableServices
|
Just l -> pure l
|
||||||
pure $ ServiceAvailableRes services
|
getPackageDetails :: MonadIO m
|
||||||
where
|
=> (HM.HashMap PkgId ([Version], [CategoryTitle]))
|
||||||
getPackageDetails :: PackageVersion -> HandlerFor RegistryCtx (Maybe (Entity SVersion), Entity SApp)
|
-> PackageVersion
|
||||||
getPackageDetails pv = do
|
-> m (Either Text ((Maybe Version), PkgId))
|
||||||
appsDir <- getsYesod $ ((</> "apps") . resourcesDir) . appSettings
|
getPackageDetails metadata pv = do
|
||||||
let appId = packageVersionId pv
|
let appId = packageVersionId pv
|
||||||
let spec = packageVersionVersion pv
|
let spec = packageVersionVersion pv
|
||||||
let appExt = Extension (toS appId) :: Extension "s9pk"
|
pacakgeMetadata <- case HM.lookup appId metadata of
|
||||||
getBestVersion appsDir appExt spec >>= \case
|
Nothing -> throwIO $ NotFoundE [i|dependency metadata for #{appId} not found.|]
|
||||||
Nothing -> sendResponseStatus
|
Just m -> pure m
|
||||||
status404
|
-- get best version from VersionRange of dependency
|
||||||
("best version could not be found for " <> appId <> " with spec " <> show spec :: Text)
|
let satisfactory = filter (<|| spec) (fst pacakgeMetadata)
|
||||||
Just v -> do
|
let best = getMax <$> foldMap (Just . Max) satisfactory
|
||||||
(service, version) <- runDB $ fetchLatestAppAtVersion appId v >>= errOnNothing
|
case best of
|
||||||
status404
|
Nothing -> pure $ Left $ [i|Best version could not be found for #{appId} with spec #{spec}|]
|
||||||
("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"
|
|
||||||
Just v -> do
|
Just v -> do
|
||||||
case readMaybe v of
|
pure $ Right (Just v, appId)
|
||||||
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
|
|
||||||
|
|
||||||
getServiceDetails :: Maybe (Entity SVersion) -> Entity SApp -> HandlerFor RegistryCtx ServiceRes
|
getServiceDetails :: (MonadIO m, MonadResource m)
|
||||||
getServiceDetails maybeVersion service = do
|
=> AppSettings
|
||||||
(versions, _) <- fetchAllAppVersions (entityKey service)
|
-> (HM.HashMap PkgId ([Version], [CategoryTitle]))
|
||||||
categories <- runDB $ fetchAppCategories (entityKey service)
|
-> Maybe Version
|
||||||
(appsDir, appMgrDir) <- getsYesod $ ((</> "apps") . resourcesDir &&& staticBinDir) . appSettings
|
-> PkgId
|
||||||
domain <- getsYesod $ registryHostname . appSettings
|
-> m (Either S9Error ServiceRes)
|
||||||
let appId = sAppAppId $ entityVal service
|
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
|
version <- case maybeVersion of
|
||||||
Nothing -> do
|
Nothing -> do
|
||||||
(_, version) <- runDB $ fetchLatestApp appId >>= errOnNothing status404 "service not found"
|
-- grab first value, which will be the latest version
|
||||||
pure $ sVersionNumber $ entityVal version
|
case fst packageMetadata of
|
||||||
Just v -> pure $ sVersionNumber $ entityVal v
|
[] -> liftEither . Left $ NotFoundE $ [i|No latest version found for #{pkg}|]
|
||||||
let appDir = (<> "/") . (</> show version) . (</> toS appId) $ appsDir
|
x : _ -> pure x
|
||||||
let appExt = Extension (toS appId) :: Extension "s9pk"
|
Just v -> pure v
|
||||||
manifest' <- handleS9ErrT $ getManifest appMgrDir appDir appExt
|
manifest <- flip runReaderT settings $ (snd <$> getManifest pkg version) >>= \bs ->
|
||||||
manifest <- case eitherDecode $ BS.fromStrict manifest' of
|
runConduit $ bs .| CL.foldMap BS.fromStrict
|
||||||
Left e -> do
|
case eitherDecode manifest of
|
||||||
$logError "could not parse service manifest!"
|
Left _ -> liftEither . Left $ AssetParseE [i|#{pkg}:manifest|] (decodeUtf8 $ BS.toStrict manifest)
|
||||||
$logError (show e)
|
Right m -> do
|
||||||
sendResponseStatus status500 ("Internal Server Error" :: Text)
|
let d = parMap rpar (mapDependencyMetadata domain metadata) (HM.toList $ serviceManifestDependencies m)
|
||||||
Right a -> pure a
|
pure $ ServiceRes { serviceResIcon = [i|https://#{domain}/package/icon/#{pkg}|]
|
||||||
d <- traverse (mapDependencyMetadata appsDir domain) (HM.toList $ serviceManifestDependencies manifest)
|
-- pass through raw JSON Value, we have checked its correct parsing above
|
||||||
pure $ ServiceRes { serviceResIcon = [i|https://#{domain}/package/icon/#{appId}|]
|
, serviceResManifest = unsafeFromJust . decode $ manifest
|
||||||
, serviceResManifest = decode $ BS.fromStrict manifest' -- pass through raw JSON Value
|
, serviceResCategories = snd packageMetadata
|
||||||
, serviceResCategories = serviceCategoryCategoryName . entityVal <$> categories
|
, serviceResInstructions = [i|https://#{domain}/package/instructions/#{pkg}|]
|
||||||
, serviceResInstructions = [i|https://#{domain}/package/instructions/#{appId}|]
|
, serviceResLicense = [i|https://#{domain}/package/license/#{pkg}|]
|
||||||
, serviceResLicense = [i|https://#{domain}/package/license/#{appId}|]
|
, serviceResVersions = fst packageMetadata
|
||||||
, serviceResVersions = versionInfoVersion <$> versions
|
, serviceResDependencyInfo = HM.fromList $ snd $ partitionEithers d
|
||||||
, serviceResDependencyInfo = HM.fromList d
|
}
|
||||||
}
|
|
||||||
|
|
||||||
type URL = Text
|
mapDependencyMetadata :: Text
|
||||||
mapDependencyMetadata :: (MonadIO m, MonadHandler m)
|
-> HM.HashMap PkgId ([Version], [CategoryTitle])
|
||||||
=> FilePath
|
-> (PkgId, ServiceDependencyInfo)
|
||||||
-> Text
|
-> Either S9Error (PkgId, DependencyInfo)
|
||||||
-> (AppIdentifier, ServiceDependencyInfo)
|
mapDependencyMetadata domain metadata (appId, depInfo) = do
|
||||||
-> m (AppIdentifier, DependencyInfo)
|
depMetadata <- case HM.lookup appId metadata of
|
||||||
mapDependencyMetadata appsDir domain (appId, depInfo) = do
|
Nothing -> Left $ NotFoundE [i|dependency metadata for #{appId} not found.|]
|
||||||
let ext = (Extension (toS appId) :: Extension "s9pk")
|
Just m -> pure m
|
||||||
-- get best version from VersionRange of dependency
|
-- get best version from VersionRange of dependency
|
||||||
version <- getBestVersion appsDir ext (serviceDependencyInfoVersion depInfo) >>= \case
|
let satisfactory = filter (<|| serviceDependencyInfoVersion depInfo) (fst depMetadata)
|
||||||
Nothing -> sendResponseStatus status404 ("best version not found for dependent package " <> appId :: Text)
|
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
|
Just v -> pure v
|
||||||
pure
|
pure
|
||||||
( appId
|
( 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 :: Key SApp -> HandlerFor RegistryCtx ([VersionInfo], ReleaseNotes)
|
||||||
fetchAllAppVersions appId = do
|
fetchAllAppVersions appId = do
|
||||||
@@ -386,6 +500,18 @@ fetchAllAppVersions appId = do
|
|||||||
let vv = mapSVersionToVersionInfo vers
|
let vv = mapSVersionToVersionInfo vers
|
||||||
let mappedVersions = ReleaseNotes $ HM.fromList $ (\v -> (versionInfoVersion v, versionInfoReleaseNotes v)) <$> vv
|
let mappedVersions = ReleaseNotes $ HM.fromList $ (\v -> (versionInfoVersion v, versionInfoReleaseNotes v)) <$> vv
|
||||||
pure (vv, mappedVersions)
|
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 :: MonadIO m => Key SApp -> ReaderT SqlBackend m [Entity SVersion]
|
||||||
fetchMostRecentAppVersions appId = select $ do
|
fetchMostRecentAppVersions appId = select $ do
|
||||||
@@ -395,7 +521,7 @@ fetchMostRecentAppVersions appId = select $ do
|
|||||||
limit 1
|
limit 1
|
||||||
pure version
|
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
|
fetchLatestApp appId = selectOne $ do
|
||||||
(service :& version) <-
|
(service :& version) <-
|
||||||
from
|
from
|
||||||
@@ -407,7 +533,7 @@ fetchLatestApp appId = selectOne $ do
|
|||||||
pure (service, version)
|
pure (service, version)
|
||||||
|
|
||||||
fetchLatestAppAtVersion :: MonadIO m
|
fetchLatestAppAtVersion :: MonadIO m
|
||||||
=> Text
|
=> PkgId
|
||||||
-> Version
|
-> Version
|
||||||
-> ReaderT SqlBackend m (Maybe (P.Entity SApp, P.Entity SVersion))
|
-> ReaderT SqlBackend m (Maybe (P.Entity SApp, P.Entity SVersion))
|
||||||
fetchLatestAppAtVersion appId version' = selectOne $ do
|
fetchLatestAppAtVersion appId version' = selectOne $ do
|
||||||
@@ -419,6 +545,38 @@ fetchLatestAppAtVersion appId version' = selectOne $ do
|
|||||||
where_ $ (service ^. SAppAppId ==. val appId) &&. (version ^. SVersionNumber ==. val version')
|
where_ $ (service ^. SAppAppId ==. val appId) &&. (version ^. SVersionNumber ==. val version')
|
||||||
pure (service, 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 :: MonadIO m => Key SApp -> ReaderT SqlBackend m [P.Entity ServiceCategory]
|
||||||
fetchAppCategories appId = select $ do
|
fetchAppCategories appId = select $ do
|
||||||
(categories :& service) <-
|
(categories :& service) <-
|
||||||
@@ -429,35 +587,6 @@ fetchAppCategories appId = select $ do
|
|||||||
where_ (service ^. SAppId ==. val appId)
|
where_ (service ^. SAppId ==. val appId)
|
||||||
pure categories
|
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
|
-- >>> encode hm
|
||||||
-- "{\"0.2.0\":\"some notes\"}"
|
-- "{\"0.2.0\":\"some notes\"}"
|
||||||
hm :: Data.Aeson.Value
|
hm :: Data.Aeson.Value
|
||||||
|
|||||||
@@ -8,31 +8,20 @@ import Startlude hiding ( toLower )
|
|||||||
import Data.Aeson
|
import Data.Aeson
|
||||||
import Yesod.Core.Content
|
import Yesod.Core.Content
|
||||||
|
|
||||||
|
import Data.Text
|
||||||
import Lib.Types.Emver
|
import Lib.Types.Emver
|
||||||
import Orphans.Emver ( )
|
import Orphans.Emver ( )
|
||||||
import Data.Text
|
|
||||||
|
|
||||||
data AppVersionRes = AppVersionRes
|
data AppVersionRes = AppVersionRes
|
||||||
{ appVersionVersion :: Version
|
{ appVersionVersion :: Version
|
||||||
, appVersionMinCompanion :: Maybe Version
|
|
||||||
, appVersionReleaseNotes :: Maybe Text
|
|
||||||
}
|
}
|
||||||
deriving (Eq, Show)
|
deriving (Eq, Show)
|
||||||
instance ToJSON AppVersionRes where
|
instance ToJSON AppVersionRes where
|
||||||
toJSON AppVersionRes { appVersionVersion, appVersionMinCompanion, appVersionReleaseNotes } =
|
toJSON AppVersionRes { appVersionVersion } = object $ ["version" .= appVersionVersion]
|
||||||
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
|
|
||||||
instance ToContent AppVersionRes where
|
instance ToContent AppVersionRes where
|
||||||
toContent = toContent . toJSON
|
toContent = toContent . toJSON
|
||||||
instance ToTypedContent AppVersionRes where
|
instance ToTypedContent AppVersionRes where
|
||||||
toTypedContent = toTypedContent . toJSON
|
toTypedContent = toTypedContent . toJSON
|
||||||
|
|
||||||
-- Ugh
|
|
||||||
instance ToContent (Maybe AppVersionRes) where
|
instance ToContent (Maybe AppVersionRes) where
|
||||||
toContent = toContent . toJSON
|
toContent = toContent . toJSON
|
||||||
instance ToTypedContent (Maybe AppVersionRes) where
|
instance ToTypedContent (Maybe AppVersionRes) where
|
||||||
@@ -47,9 +36,10 @@ instance ToJSON SystemStatus where
|
|||||||
toJSON = String . toLower . show
|
toJSON = String . toLower . show
|
||||||
|
|
||||||
data OSVersionRes = OSVersionRes
|
data OSVersionRes = OSVersionRes
|
||||||
{ osVersionStatus :: SystemStatus
|
{ osVersionStatus :: SystemStatus
|
||||||
, osVersionVersion :: Version
|
, osVersionVersion :: Version
|
||||||
} deriving (Eq, Show)
|
}
|
||||||
|
deriving (Eq, Show)
|
||||||
instance ToJSON OSVersionRes where
|
instance ToJSON OSVersionRes where
|
||||||
toJSON OSVersionRes {..} = object ["status" .= osVersionStatus, "version" .= osVersionVersion]
|
toJSON OSVersionRes {..} = object ["status" .= osVersionStatus, "version" .= osVersionVersion]
|
||||||
instance ToContent OSVersionRes where
|
instance ToContent OSVersionRes where
|
||||||
|
|||||||
@@ -2,52 +2,34 @@
|
|||||||
{-# LANGUAGE QuasiQuotes #-}
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
{-# LANGUAGE RecordWildCards #-}
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
|
|
||||||
module Handler.Version where
|
module Handler.Version where
|
||||||
|
|
||||||
import Startlude hiding ( Handler )
|
import Startlude hiding ( Handler )
|
||||||
|
|
||||||
import Control.Monad.Trans.Maybe
|
|
||||||
import Yesod.Core
|
import Yesod.Core
|
||||||
|
|
||||||
|
import Data.String.Interpolate.IsString
|
||||||
|
( i )
|
||||||
import Foundation
|
import Foundation
|
||||||
import Handler.Types.Status
|
import Handler.Types.Status
|
||||||
import Lib.Registry
|
import Lib.Error ( S9Error(NotFoundE) )
|
||||||
import Lib.Types.Emver
|
import Lib.PkgRepository ( getBestVersion )
|
||||||
|
import Lib.Types.AppIndex ( PkgId )
|
||||||
|
import Network.HTTP.Types.Status ( status404 )
|
||||||
import Settings
|
import Settings
|
||||||
import System.FilePath ( (</>) )
|
import Util.Shared ( getVersionSpecFromQuery
|
||||||
import Util.Shared
|
, orThrow
|
||||||
import System.Directory ( doesFileExist )
|
)
|
||||||
|
|
||||||
getVersionR :: Handler AppVersionRes
|
getVersionR :: Handler AppVersionRes
|
||||||
getVersionR = do
|
getVersionR = AppVersionRes . registryVersion . appSettings <$> getYesod
|
||||||
rv <- AppVersionRes . registryVersion . appSettings <$> getYesod
|
|
||||||
pure $ rv Nothing Nothing
|
|
||||||
|
|
||||||
getVersionAppR :: Text -> Handler (Maybe AppVersionRes)
|
getPkgVersionR :: PkgId -> Handler AppVersionRes
|
||||||
getVersionAppR appId = do
|
getPkgVersionR pkg = do
|
||||||
(appsDir, appMgrDir) <- getsYesod $ ((</> "apps") . resourcesDir &&& staticBinDir) . appSettings
|
spec <- getVersionSpecFromQuery
|
||||||
res <- getVersionWSpec appsDir appExt
|
AppVersionRes <$> getBestVersion pkg spec `orThrow` sendResponseStatus
|
||||||
case res of
|
status404
|
||||||
Nothing -> pure res
|
(NotFoundE [i|Version for #{pkg} satisfying #{spec}|])
|
||||||
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)
|
|
||||||
|
|||||||
@@ -5,15 +5,18 @@ module Lib.Error where
|
|||||||
|
|
||||||
import Startlude
|
import Startlude
|
||||||
|
|
||||||
|
import Data.String.Interpolate.IsString
|
||||||
import Network.HTTP.Types
|
import Network.HTTP.Types
|
||||||
import Yesod.Core
|
import Yesod.Core
|
||||||
import Data.String.Interpolate.IsString
|
|
||||||
|
|
||||||
type S9ErrT m = ExceptT S9Error m
|
type S9ErrT m = ExceptT S9Error m
|
||||||
|
|
||||||
data S9Error =
|
data S9Error =
|
||||||
PersistentE Text
|
PersistentE Text
|
||||||
| AppMgrE Text Int
|
| AppMgrE Text ExitCode
|
||||||
|
| NotFoundE Text
|
||||||
|
| InvalidParamsE Text Text
|
||||||
|
| AssetParseE Text Text
|
||||||
deriving (Show, Eq)
|
deriving (Show, Eq)
|
||||||
|
|
||||||
instance Exception S9Error
|
instance Exception S9Error
|
||||||
@@ -21,13 +24,18 @@ instance Exception S9Error
|
|||||||
-- | Redact any sensitive data in this function
|
-- | Redact any sensitive data in this function
|
||||||
toError :: S9Error -> Error
|
toError :: S9Error -> Error
|
||||||
toError = \case
|
toError = \case
|
||||||
PersistentE t -> Error DATABASE_ERROR t
|
PersistentE t -> Error DATABASE_ERROR t
|
||||||
AppMgrE cmd code -> Error APPMGR_ERROR [i|"appmgr #{cmd}" exited with #{code}|]
|
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 =
|
data ErrorCode =
|
||||||
DATABASE_ERROR
|
DATABASE_ERROR
|
||||||
| APPMGR_ERROR
|
| APPMGR_ERROR
|
||||||
|
| NOT_FOUND
|
||||||
|
| INVALID_PARAMS
|
||||||
|
| PARSE_ERROR
|
||||||
deriving (Eq, Show)
|
deriving (Eq, Show)
|
||||||
instance ToJSON ErrorCode where
|
instance ToJSON ErrorCode where
|
||||||
toJSON = String . show
|
toJSON = String . show
|
||||||
@@ -51,8 +59,11 @@ instance ToContent S9Error where
|
|||||||
|
|
||||||
toStatus :: S9Error -> Status
|
toStatus :: S9Error -> Status
|
||||||
toStatus = \case
|
toStatus = \case
|
||||||
PersistentE _ -> status500
|
PersistentE _ -> status500
|
||||||
AppMgrE _ _ -> status500
|
AppMgrE _ _ -> status500
|
||||||
|
NotFoundE _ -> status404
|
||||||
|
InvalidParamsE _ _ -> status400
|
||||||
|
AssetParseE _ _ -> status500
|
||||||
|
|
||||||
|
|
||||||
handleS9ErrT :: MonadHandler m => S9ErrT m a -> m a
|
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 TupleSections #-}
|
||||||
{-# LANGUAGE TypeApplications #-}
|
{-# LANGUAGE TypeApplications #-}
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
{-# LANGUAGE BangPatterns #-}
|
||||||
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
|
||||||
module Lib.External.AppMgr where
|
module Lib.External.AppMgr where
|
||||||
|
|
||||||
import Startlude
|
import Startlude hiding ( bracket
|
||||||
|
, catch
|
||||||
|
, finally
|
||||||
|
, handle
|
||||||
|
)
|
||||||
|
|
||||||
import qualified Data.ByteString.Lazy as LBS
|
import qualified Data.ByteString.Lazy as LBS
|
||||||
import Data.String.Interpolate.IsString
|
import Data.String.Interpolate.IsString
|
||||||
import System.Process.Typed hiding ( createPipe )
|
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.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' :: MonadIO m => String -> [String] -> ByteString -> m (ExitCode, ByteString, ByteString)
|
||||||
readProcessWithExitCode' a b c = liftIO $ do
|
readProcessWithExitCode' a b c = liftIO $ do
|
||||||
@@ -31,57 +53,75 @@ readProcessWithExitCode' a b c = liftIO $ do
|
|||||||
(LBS.toStrict <$> getStdout process)
|
(LBS.toStrict <$> getStdout process)
|
||||||
(LBS.toStrict <$> getStderr process)
|
(LBS.toStrict <$> getStderr process)
|
||||||
|
|
||||||
readProcessInheritStderr :: MonadIO m => String -> [String] -> ByteString -> m (ExitCode, ByteString)
|
readProcessInheritStderr :: forall m a
|
||||||
readProcessInheritStderr a b c = liftIO $ do
|
. 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 =
|
let pc =
|
||||||
setStdin (byteStringInput $ LBS.fromStrict c)
|
setStdin (byteStringInput $ LBS.fromStrict c)
|
||||||
$ setStderr inherit
|
|
||||||
$ setEnvInherit
|
$ setEnvInherit
|
||||||
$ setStdout byteStringOutput
|
$ setStderr (useHandleOpen stderr)
|
||||||
|
$ setStdout createSource
|
||||||
$ System.Process.Typed.proc a b
|
$ System.Process.Typed.proc a b
|
||||||
withProcessWait pc
|
withProcessTerm' pc $ \p -> sink (getStdout p)
|
||||||
$ \process -> atomically $ liftA2 (,) (waitExitCodeSTM process) (LBS.toStrict <$> getStdout process)
|
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
|
sourceManifest :: (MonadUnliftIO m, MonadLoggerIO m)
|
||||||
getConfig appmgrPath appPath e@(Extension appId) = fmap decodeUtf8 $ do
|
=> FilePath
|
||||||
(ec, out) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk")
|
-> FilePath
|
||||||
["inspect", "config", appPath <> show e, "--json"]
|
-> (ConduitT () ByteString m () -> m r)
|
||||||
""
|
-> m r
|
||||||
case ec of
|
sourceManifest appmgrPath pkgFile sink = do
|
||||||
ExitSuccess -> pure out
|
let appmgr = readProcessInheritStderr (appmgrPath </> "embassy-sdk") ["inspect", "manifest", pkgFile] ""
|
||||||
ExitFailure n -> throwE $ AppMgrE [i|info config #{appId} \--json|] n
|
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
|
sourceIcon :: (MonadUnliftIO m, MonadLoggerIO m) => FilePath -> FilePath -> (ConduitT () ByteString m () -> m r) -> m r
|
||||||
getManifest appmgrPath appPath e@(Extension appId) = do
|
sourceIcon appmgrPath pkgFile sink = do
|
||||||
(ec, bs) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "manifest", appPath <> show e] ""
|
let appmgr = readProcessInheritStderr (appmgrPath </> "embassy-sdk") ["inspect", "icon", pkgFile] ""
|
||||||
case ec of
|
appmgr sink `catch` \ece ->
|
||||||
ExitSuccess -> pure bs
|
$logErrorSH ece *> throwIO (AppMgrE [i|embassy-sdk inspect icon #{pkgFile}|] (eceExitCode ece))
|
||||||
ExitFailure n -> throwE $ AppMgrE [i|embassy-sdk inspect manifest #{appId}|] n
|
|
||||||
|
|
||||||
getIcon :: (MonadIO m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> S9ErrT m ByteString
|
getPackageHash :: (MonadUnliftIO m, MonadLoggerIO m) => FilePath -> FilePath -> m ByteString
|
||||||
getIcon appmgrPath appPath e@(Extension icon) = do
|
getPackageHash appmgrPath pkgFile = do
|
||||||
(ec, bs) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "icon", appPath] ""
|
let appmgr = readProcessInheritStderr (appmgrPath </> "embassy-sdk") ["inspect", "hash", pkgFile] ""
|
||||||
case ec of
|
appmgr (\bsSource -> runConduit $ bsSource .| CL.foldMap id) `catch` \ece ->
|
||||||
ExitSuccess -> pure bs
|
$logErrorSH ece *> throwIO (AppMgrE [i|embassy-sdk inspect hash #{pkgFile}|] (eceExitCode ece))
|
||||||
ExitFailure n -> throwE $ AppMgrE [i|embassy-sdk inspect icon #{icon}|] n
|
|
||||||
|
|
||||||
getPackageHash :: (MonadIO m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> S9ErrT m ByteString
|
sourceInstructions :: (MonadUnliftIO m, MonadLoggerIO m)
|
||||||
getPackageHash appmgrPath appPath e@(Extension appId) = do
|
=> FilePath
|
||||||
(ec, bs) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "hash", appPath <> show e] ""
|
-> FilePath
|
||||||
case ec of
|
-> (ConduitT () ByteString m () -> m r)
|
||||||
ExitSuccess -> pure bs
|
-> m r
|
||||||
ExitFailure n -> throwE $ AppMgrE [i|embassy-sdk inspect hash #{appId}|] n
|
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
|
sourceLicense :: (MonadUnliftIO m, MonadLoggerIO m)
|
||||||
getInstructions appmgrPath appPath e@(Extension appId) = do
|
=> FilePath
|
||||||
(ec, bs) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "instructions", appPath] ""
|
-> FilePath
|
||||||
case ec of
|
-> (ConduitT () ByteString m () -> m r)
|
||||||
ExitSuccess -> pure bs
|
-> m r
|
||||||
ExitFailure n -> throwE $ AppMgrE [i|embassy-sdk inspect instructions #{appId}|] n
|
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
|
sinkMem :: (Monad m, Monoid a) => ConduitT () a m () -> m a
|
||||||
getLicense appmgrPath appPath e@(Extension appId) = do
|
sinkMem c = runConduit $ c .| CL.foldMap id
|
||||||
(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
|
|
||||||
|
|||||||
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.HashMap.Strict as HM
|
||||||
import qualified Data.List.NonEmpty as NE
|
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 Lib.Types.Emver
|
||||||
import Orphans.Emver ( )
|
import Orphans.Emver ( )
|
||||||
import System.Directory
|
import System.Directory
|
||||||
import Lib.Registry
|
import Yesod
|
||||||
import Model
|
|
||||||
import qualified Data.Text as T
|
|
||||||
import Data.String.Interpolate.IsString
|
|
||||||
import qualified Data.ByteString.Lazy as BS
|
|
||||||
|
|
||||||
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
|
data VersionInfo = VersionInfo
|
||||||
{ versionInfoVersion :: Version
|
{ versionInfoVersion :: Version
|
||||||
, versionInfoReleaseNotes :: Text
|
, versionInfoReleaseNotes :: Text
|
||||||
, versionInfoDependencies :: HM.HashMap AppIdentifier VersionRange
|
, versionInfoDependencies :: HM.HashMap PkgId VersionRange
|
||||||
, versionInfoOsRequired :: VersionRange
|
, versionInfoOsRequired :: VersionRange
|
||||||
, versionInfoOsRecommended :: VersionRange
|
, versionInfoOsRecommended :: VersionRange
|
||||||
, versionInfoInstallAlert :: Maybe Text
|
, versionInfoInstallAlert :: Maybe Text
|
||||||
}
|
}
|
||||||
deriving (Eq, Show)
|
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
|
instance Ord VersionInfo where
|
||||||
compare = compare `on` versionInfoVersion
|
compare = compare `on` versionInfoVersion
|
||||||
|
|
||||||
@@ -88,7 +111,7 @@ instance ToJSON StoreApp where
|
|||||||
, "version-info" .= storeAppVersionInfo
|
, "version-info" .= storeAppVersionInfo
|
||||||
, "timestamp" .= storeAppTimestamp
|
, "timestamp" .= storeAppTimestamp
|
||||||
]
|
]
|
||||||
newtype AppManifest = AppManifest { unAppManifest :: HM.HashMap AppIdentifier StoreApp}
|
newtype AppManifest = AppManifest { unAppManifest :: HM.HashMap PkgId StoreApp}
|
||||||
deriving (Show)
|
deriving (Show)
|
||||||
|
|
||||||
instance FromJSON AppManifest where
|
instance FromJSON AppManifest where
|
||||||
@@ -128,11 +151,12 @@ addFileTimestamp appDir ext service v = do
|
|||||||
pure $ Just service { storeAppTimestamp = Just time }
|
pure $ Just service { storeAppTimestamp = Just time }
|
||||||
|
|
||||||
data ServiceDependencyInfo = ServiceDependencyInfo
|
data ServiceDependencyInfo = ServiceDependencyInfo
|
||||||
{ serviceDependencyInfoOptional :: Maybe Text
|
{ serviceDependencyInfoOptional :: Maybe Text
|
||||||
, serviceDependencyInfoVersion :: VersionRange
|
, serviceDependencyInfoVersion :: VersionRange
|
||||||
, serviceDependencyInfoDescription :: Maybe Text
|
, serviceDependencyInfoDescription :: Maybe Text
|
||||||
, serviceDependencyInfoCritical :: Bool
|
, serviceDependencyInfoCritical :: Bool
|
||||||
} deriving (Show)
|
}
|
||||||
|
deriving Show
|
||||||
instance FromJSON ServiceDependencyInfo where
|
instance FromJSON ServiceDependencyInfo where
|
||||||
parseJSON = withObject "service dependency info" $ \o -> do
|
parseJSON = withObject "service dependency info" $ \o -> do
|
||||||
serviceDependencyInfoOptional <- o .:? "optional"
|
serviceDependencyInfoOptional <- o .:? "optional"
|
||||||
@@ -162,16 +186,17 @@ instance FromJSON ServiceAlert where
|
|||||||
"stop" -> pure STOP
|
"stop" -> pure STOP
|
||||||
_ -> fail "unknown service alert type"
|
_ -> fail "unknown service alert type"
|
||||||
data ServiceManifest = ServiceManifest
|
data ServiceManifest = ServiceManifest
|
||||||
{ serviceManifestId :: AppIdentifier
|
{ serviceManifestId :: !PkgId
|
||||||
, serviceManifestTitle :: Text
|
, serviceManifestTitle :: !Text
|
||||||
, serviceManifestVersion :: Version
|
, serviceManifestVersion :: !Version
|
||||||
, serviceManifestDescriptionLong :: Text
|
, serviceManifestDescriptionLong :: !Text
|
||||||
, serviceManifestDescriptionShort :: Text
|
, serviceManifestDescriptionShort :: !Text
|
||||||
, serviceManifestReleaseNotes :: Text
|
, serviceManifestReleaseNotes :: !Text
|
||||||
, serviceManifestIcon :: Maybe Text
|
, serviceManifestIcon :: !(Maybe Text)
|
||||||
, serviceManifestAlerts :: HM.HashMap ServiceAlert (Maybe Text)
|
, serviceManifestAlerts :: !(HM.HashMap ServiceAlert (Maybe Text))
|
||||||
, serviceManifestDependencies :: HM.HashMap AppIdentifier ServiceDependencyInfo
|
, serviceManifestDependencies :: !(HM.HashMap PkgId ServiceDependencyInfo)
|
||||||
} deriving (Show)
|
}
|
||||||
|
deriving Show
|
||||||
instance FromJSON ServiceManifest where
|
instance FromJSON ServiceManifest where
|
||||||
parseJSON = withObject "service manifest" $ \o -> do
|
parseJSON = withObject "service manifest" $ \o -> do
|
||||||
serviceManifestId <- o .: "id"
|
serviceManifestId <- o .: "id"
|
||||||
@@ -203,7 +228,7 @@ instance ToJSON ServiceManifest where
|
|||||||
]
|
]
|
||||||
|
|
||||||
-- >>> eitherDecode testManifest :: Either String ServiceManifest
|
-- >>> 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 :: BS.ByteString
|
||||||
testManifest = [i|{
|
testManifest = [i|{
|
||||||
"id": "embassy-pages",
|
"id": "embassy-pages",
|
||||||
|
|||||||
@@ -1,5 +1,6 @@
|
|||||||
{-# LANGUAGE TemplateHaskell #-}
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
{-# LANGUAGE QuasiQuotes #-}
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
|
|
||||||
module Lib.Types.Category where
|
module Lib.Types.Category where
|
||||||
|
|
||||||
@@ -16,7 +17,7 @@ data CategoryTitle = FEATURED
|
|||||||
| MESSAGING
|
| MESSAGING
|
||||||
| SOCIAL
|
| SOCIAL
|
||||||
| ALTCOIN
|
| ALTCOIN
|
||||||
deriving (Eq, Enum, Show, Read)
|
deriving (Eq, Enum, Show, Read, Generic)
|
||||||
instance PersistField CategoryTitle where
|
instance PersistField CategoryTitle where
|
||||||
fromPersistValue = fromPersistValueJSON
|
fromPersistValue = fromPersistValueJSON
|
||||||
toPersistValue = toPersistValueJSON
|
toPersistValue = toPersistValueJSON
|
||||||
@@ -46,3 +47,4 @@ instance ToContent CategoryTitle where
|
|||||||
toContent = toContent . toJSON
|
toContent = toContent . toJSON
|
||||||
instance ToTypedContent CategoryTitle where
|
instance ToTypedContent CategoryTitle where
|
||||||
toTypedContent = toTypedContent . toJSON
|
toTypedContent = toTypedContent . toJSON
|
||||||
|
instance Hashable CategoryTitle
|
||||||
|
|||||||
@@ -34,28 +34,26 @@ module Lib.Types.Emver
|
|||||||
, exactly
|
, exactly
|
||||||
, parseVersion
|
, parseVersion
|
||||||
, parseRange
|
, parseRange
|
||||||
)
|
) where
|
||||||
where
|
|
||||||
|
|
||||||
import Prelude
|
import Startlude hiding ( Any )
|
||||||
import qualified Data.Attoparsec.Text as Atto
|
|
||||||
import Data.Function
|
import Control.Monad.Fail ( fail )
|
||||||
import Data.Functor ( (<&>)
|
|
||||||
, ($>)
|
|
||||||
)
|
|
||||||
import Control.Applicative ( liftA2
|
|
||||||
, Alternative((<|>))
|
|
||||||
)
|
|
||||||
import Data.String ( IsString(..) )
|
|
||||||
import qualified Data.Text as T
|
|
||||||
import Data.Aeson
|
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.
|
-- | AppVersion is the core representation of the SemverQuad type.
|
||||||
newtype Version = Version { unVersion :: (Word, Word, Word, Word) } deriving (Eq, Ord, ToJSONKey, Hashable)
|
newtype Version = Version { unVersion :: (Word, Word, Word, Word) } deriving (Eq, Ord, ToJSONKey, Hashable)
|
||||||
instance Show Version where
|
instance Show Version where
|
||||||
show (Version (x, y, z, q)) =
|
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
|
instance IsString Version where
|
||||||
fromString s = either error id $ Atto.parseOnly parseVersion (T.pack s)
|
fromString s = either error id $ Atto.parseOnly parseVersion (T.pack s)
|
||||||
instance Read Version where
|
instance Read Version where
|
||||||
@@ -135,17 +133,17 @@ exactly :: Version -> VersionRange
|
|||||||
exactly = Anchor (Right EQ)
|
exactly = Anchor (Right EQ)
|
||||||
|
|
||||||
instance Show VersionRange where
|
instance Show VersionRange where
|
||||||
show (Anchor ( Left EQ) v ) = '!' : '=' : show v
|
show (Anchor ( Left EQ) v ) = '!' : '=' : GHC.show v
|
||||||
show (Anchor ( Right EQ) v ) = '=' : show v
|
show (Anchor ( Right EQ) v ) = '=' : GHC.show v
|
||||||
show (Anchor ( Left LT) v ) = '>' : '=' : show v
|
show (Anchor ( Left LT) v ) = '>' : '=' : GHC.show v
|
||||||
show (Anchor ( Right LT) v ) = '<' : show v
|
show (Anchor ( Right LT) v ) = '<' : GHC.show v
|
||||||
show (Anchor ( Left GT) v ) = '<' : '=' : show v
|
show (Anchor ( Left GT) v ) = '<' : '=' : GHC.show v
|
||||||
show (Anchor ( Right GT) v ) = '>' : show v
|
show (Anchor ( Right GT) v ) = '>' : GHC.show v
|
||||||
show (Conj a@(Disj _ _) b@(Disj _ _)) = paren (show a) <> (' ' : paren (show b))
|
show (Conj a@(Disj _ _) b@(Disj _ _)) = paren (GHC.show a) <> (' ' : paren (GHC.show b))
|
||||||
show (Conj a@(Disj _ _) b ) = paren (show a) <> (' ' : show b)
|
show (Conj a@(Disj _ _) b ) = paren (GHC.show a) <> (' ' : GHC.show b)
|
||||||
show (Conj a b@(Disj _ _)) = show a <> (' ' : paren (show b))
|
show (Conj a b@(Disj _ _)) = GHC.show a <> (' ' : paren (GHC.show b))
|
||||||
show (Conj a b ) = show a <> (' ' : show b)
|
show (Conj a b ) = GHC.show a <> (' ' : GHC.show b)
|
||||||
show (Disj a b ) = show a <> " || " <> show b
|
show (Disj a b ) = GHC.show a <> " || " <> GHC.show b
|
||||||
show Any = "*"
|
show Any = "*"
|
||||||
show None = "!"
|
show None = "!"
|
||||||
instance Read VersionRange where
|
instance Read VersionRange where
|
||||||
@@ -184,10 +182,6 @@ satisfies _ None = False
|
|||||||
(||>) = flip satisfies
|
(||>) = flip satisfies
|
||||||
{-# INLINE (||>) #-}
|
{-# INLINE (||>) #-}
|
||||||
|
|
||||||
(<<$>>) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b)
|
|
||||||
(<<$>>) = fmap . fmap
|
|
||||||
{-# INLINE (<<$>>) #-}
|
|
||||||
|
|
||||||
parseOperator :: Atto.Parser Operator
|
parseOperator :: Atto.Parser Operator
|
||||||
parseOperator =
|
parseOperator =
|
||||||
(Atto.char '=' $> Right EQ)
|
(Atto.char '=' $> Right EQ)
|
||||||
|
|||||||
@@ -10,18 +10,19 @@
|
|||||||
|
|
||||||
module Model where
|
module Model where
|
||||||
|
|
||||||
import Startlude
|
|
||||||
import Database.Persist.TH
|
import Database.Persist.TH
|
||||||
import Lib.Types.Emver
|
import Lib.Types.AppIndex
|
||||||
import Lib.Types.Category
|
import Lib.Types.Category
|
||||||
|
import Lib.Types.Emver
|
||||||
import Orphans.Emver ( )
|
import Orphans.Emver ( )
|
||||||
|
import Startlude
|
||||||
|
|
||||||
share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
|
share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
|
||||||
SApp
|
SApp
|
||||||
createdAt UTCTime
|
createdAt UTCTime
|
||||||
updatedAt UTCTime Maybe
|
updatedAt UTCTime Maybe
|
||||||
title Text
|
title Text
|
||||||
appId Text
|
appId PkgId
|
||||||
descShort Text
|
descShort Text
|
||||||
descLong Text
|
descLong Text
|
||||||
iconType Text
|
iconType Text
|
||||||
@@ -63,8 +64,8 @@ Category
|
|||||||
name CategoryTitle
|
name CategoryTitle
|
||||||
parent CategoryId Maybe
|
parent CategoryId Maybe
|
||||||
description Text
|
description Text
|
||||||
UniqueName name
|
|
||||||
priority Int default=0
|
priority Int default=0
|
||||||
|
UniqueName name
|
||||||
deriving Eq
|
deriving Eq
|
||||||
deriving Show
|
deriving Show
|
||||||
|
|
||||||
|
|||||||
@@ -9,10 +9,10 @@ import Startlude
|
|||||||
import Data.Aeson
|
import Data.Aeson
|
||||||
import qualified Data.Attoparsec.Text as Atto
|
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 Control.Monad.Fail ( MonadFail(fail) )
|
||||||
|
import qualified Data.Text as T
|
||||||
|
import Database.Persist.Sql
|
||||||
|
import Lib.Types.Emver
|
||||||
|
|
||||||
instance FromJSON Version where
|
instance FromJSON Version where
|
||||||
parseJSON = withText "Emver Version" $ either fail pure . Atto.parseOnly parseVersion
|
parseJSON = withText "Emver Version" $ either fail pure . Atto.parseOnly parseVersion
|
||||||
|
|||||||
@@ -1,5 +1,6 @@
|
|||||||
{-# LANGUAGE RecordWildCards #-}
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
-- | Settings are centralized, as much as possible, into this file. This
|
-- | Settings are centralized, as much as possible, into this file. This
|
||||||
-- includes database connection settings, static file locations, etc.
|
-- includes database connection settings, static file locations, etc.
|
||||||
-- In addition, you can configure a number of different aspects of Yesod
|
-- 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 System.FilePath ( (</>) )
|
||||||
import Yesod.Default.Config2 ( configSettingsYml )
|
import Yesod.Default.Config2 ( configSettingsYml )
|
||||||
|
|
||||||
|
import Control.Monad.Reader.Has ( Has(extract, update) )
|
||||||
|
import Lib.PkgRepository ( PkgRepo(..) )
|
||||||
import Lib.Types.Emver
|
import Lib.Types.Emver
|
||||||
import Network.Wai ( FilePart )
|
|
||||||
import Orphans.Emver ( )
|
import Orphans.Emver ( )
|
||||||
-- | Runtime settings to configure this application. These settings can be
|
-- | Runtime settings to configure this application. These settings can be
|
||||||
-- loaded from various sources: defaults, environment variables, config files,
|
-- loaded from various sources: defaults, environment variables, config files,
|
||||||
@@ -55,6 +57,11 @@ data AppSettings = AppSettings
|
|||||||
, staticBinDir :: FilePath
|
, staticBinDir :: FilePath
|
||||||
, errorLogRoot :: 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
|
instance FromJSON AppSettings where
|
||||||
parseJSON = withObject "AppSettings" $ \o -> do
|
parseJSON = withObject "AppSettings" $ \o -> do
|
||||||
|
|||||||
@@ -21,3 +21,6 @@ mapFind finder mapping (b : bs) =
|
|||||||
(Nothing, Just _) -> Just b
|
(Nothing, Just _) -> Just b
|
||||||
_ -> Nothing
|
_ -> 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 TemplateHaskell #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
|
||||||
module Util.Shared where
|
module Util.Shared where
|
||||||
|
|
||||||
@@ -8,34 +9,27 @@ import qualified Data.Text as T
|
|||||||
import Network.HTTP.Types
|
import Network.HTTP.Types
|
||||||
import Yesod.Core
|
import Yesod.Core
|
||||||
|
|
||||||
|
import Control.Monad.Reader.Has ( Has )
|
||||||
import Foundation
|
import Foundation
|
||||||
import Lib.Registry
|
import Lib.PkgRepository ( PkgRepo
|
||||||
|
, getHash
|
||||||
|
)
|
||||||
|
import Lib.Types.AppIndex ( PkgId )
|
||||||
import Lib.Types.Emver
|
import Lib.Types.Emver
|
||||||
import Data.Semigroup
|
|
||||||
import Lib.External.AppMgr
|
|
||||||
import Lib.Error
|
|
||||||
|
|
||||||
getVersionFromQuery :: KnownSymbol a => FilePath -> Extension a -> Handler (Maybe Version)
|
getVersionSpecFromQuery :: Handler VersionRange
|
||||||
getVersionFromQuery rootDir ext = do
|
getVersionSpecFromQuery = do
|
||||||
specString <- T.filter (not . isSpace) . fromMaybe "*" <$> lookupGetParam "spec"
|
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)
|
Nothing -> sendResponseStatus status400 ("Invalid App Version Specification" :: Text)
|
||||||
Just t -> pure t
|
Just t -> pure t
|
||||||
getBestVersion rootDir ext spec
|
|
||||||
|
|
||||||
getBestVersion :: (MonadIO m, KnownSymbol a, MonadLogger m)
|
addPackageHeader :: (MonadUnliftIO m, MonadHandler m, MonadReader r m, Has PkgRepo r) => PkgId -> Version -> m ()
|
||||||
=> FilePath
|
addPackageHeader pkg version = do
|
||||||
-> Extension a
|
packageHash <- getHash pkg version
|
||||||
-> 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
|
|
||||||
addHeader "X-S9PK-HASH" $ decodeUtf8 packageHash
|
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: ./custom-snapshot.yaml
|
||||||
# resolver: https://example.com/snapshots/2018-01-01.yaml
|
# resolver: https://example.com/snapshots/2018-01-01.yaml
|
||||||
resolver: lts-18.6
|
resolver: lts-18.11
|
||||||
|
|
||||||
# User packages to be built.
|
# User packages to be built.
|
||||||
# Various formats can be used as shown in the example below.
|
# Various formats can be used as shown in the example below.
|
||||||
@@ -29,7 +29,7 @@ resolver: lts-18.6
|
|||||||
# - auto-update
|
# - auto-update
|
||||||
# - wai
|
# - wai
|
||||||
packages:
|
packages:
|
||||||
- .
|
- .
|
||||||
# Dependency packages to be pulled from upstream that are not in the resolver.
|
# Dependency packages to be pulled from upstream that are not in the resolver.
|
||||||
# These entries can reference officially published versions as well as
|
# These entries can reference officially published versions as well as
|
||||||
# forks / in-progress versions pinned to a git hash. For example:
|
# forks / in-progress versions pinned to a git hash. For example:
|
||||||
@@ -42,8 +42,8 @@ packages:
|
|||||||
extra-deps:
|
extra-deps:
|
||||||
- protolude-0.3.0
|
- protolude-0.3.0
|
||||||
- esqueleto-3.5.1.0
|
- esqueleto-3.5.1.0
|
||||||
|
- monad-logger-extras-0.1.1.1
|
||||||
- wai-request-spec-0.10.2.4
|
- wai-request-spec-0.10.2.4
|
||||||
|
|
||||||
# Override default flag values for local packages and extra-deps
|
# Override default flag values for local packages and extra-deps
|
||||||
# flags: {}
|
# flags: {}
|
||||||
|
|
||||||
@@ -68,4 +68,4 @@ extra-deps:
|
|||||||
# Allow a newer minor version of GHC than the snapshot specifies
|
# Allow a newer minor version of GHC than the snapshot specifies
|
||||||
# compiler-check: newer-minor
|
# compiler-check: newer-minor
|
||||||
# docker:
|
# docker:
|
||||||
# enable: true
|
# enable: true
|
||||||
|
|||||||
@@ -14,68 +14,65 @@ import Model
|
|||||||
|
|
||||||
spec :: Spec
|
spec :: Spec
|
||||||
spec = do
|
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
|
request $ do
|
||||||
setMethod "GET"
|
setMethod "GET"
|
||||||
setUrl ("/apps" :: Text)
|
setUrl ("/package/index" :: Text)
|
||||||
bodyContains "bitcoind"
|
bodyContains "embassy-pages"
|
||||||
bodyContains "version: 0.18.1"
|
bodyContains "version: 0.1.3"
|
||||||
statusIs 200
|
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
|
request $ do
|
||||||
setMethod "GET"
|
setMethod "GET"
|
||||||
setUrl ("/apps/bitcoind.s9pk?spec=0.18.3" :: Text)
|
setUrl ("/package/tempapp.s9pk?spec=0.0.1" :: Text)
|
||||||
statusIs 404
|
statusIs 404
|
||||||
describe "GET /apps/:appId with unknown app" $ withApp $ it "fails to get an unregistered app" $ do
|
describe "GET /package/:appId with existing version spec for embassy-pages"
|
||||||
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"
|
|
||||||
$ withApp
|
$ withApp
|
||||||
$ it "creates app and metric records"
|
$ it "creates app and metric records"
|
||||||
$ do
|
$ do
|
||||||
request $ do
|
request $ do
|
||||||
setMethod "GET"
|
setMethod "GET"
|
||||||
setUrl ("/apps/bitcoind.s9pk?spec==0.18.1" :: Text)
|
setUrl ("/package/embassy-pages.s9pk?spec==0.1.3" :: Text)
|
||||||
statusIs 200
|
statusIs 200
|
||||||
apps <- runDBtest $ selectList [SAppAppId ==. "bitcoind"] []
|
apps <- runDBtest $ selectList [SAppAppId ==. "embassy-pages"] []
|
||||||
assertEq "app should exist" (length apps) 1
|
assertEq "app should exist" (length apps) 1
|
||||||
let app = fromJust $ head apps
|
let app = fromJust $ head apps
|
||||||
metrics <- runDBtest $ selectList [MetricAppId ==. entityKey app] []
|
metrics <- runDBtest $ selectList [MetricAppId ==. entityKey app] []
|
||||||
assertEq "metric should exist" (length metrics) 1
|
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
|
describe "GET /package/:appId with existing version spec for filebrowser"
|
||||||
request $ do
|
$ withApp
|
||||||
setMethod "GET"
|
$ it "creates app and metric records"
|
||||||
setUrl ("/apps/cups.s9pk?spec=0.2.1" :: Text)
|
$ do
|
||||||
statusIs 200
|
request $ do
|
||||||
apps <- runDBtest $ selectList [SAppAppId ==. "cups"] []
|
setMethod "GET"
|
||||||
assertEq "app should exist" (length apps) 1
|
setUrl ("/package/filebrowser.s9pk?spec==2.14.1.1" :: Text)
|
||||||
let app = fromJust $ head apps
|
statusIs 200
|
||||||
metrics <- runDBtest $ selectList [MetricAppId ==. entityKey app] []
|
apps <- runDBtest $ selectList [SAppAppId ==. "filebrowser"] []
|
||||||
assertEq "metric should exist" (length metrics) 1
|
assertEq "app should exist" (length apps) 1
|
||||||
version <- runDBtest $ selectList [SVersionAppId ==. entityKey app] []
|
let app = fromJust $ head apps
|
||||||
assertEq "version should exist" (length version) 1
|
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
|
describe "GET /sys/proxy.pac" $ withApp $ it "does not record metric but request successful" $ do
|
||||||
request $ do
|
request $ do
|
||||||
setMethod "GET"
|
setMethod "GET"
|
||||||
setUrl ("/sys/proxy.pac?spec=0.1.0" :: Text)
|
setUrl ("/sys/proxy.pac?spec=0.1.0" :: Text)
|
||||||
statusIs 200
|
statusIs 200
|
||||||
-- select * from s_app
|
|
||||||
apps <- runDBtest $ selectList ([] :: [Filter SApp]) []
|
apps <- runDBtest $ selectList ([] :: [Filter SApp]) []
|
||||||
assertEq "no apps should exist" (length apps) 0
|
assertEq "no apps should exist" (length apps) 0
|
||||||
describe "GET /sys/:sysId" $ withApp $ it "does not record metric but request successful" $ do
|
describe "GET /sys/:sysId" $ withApp $ it "does not record metric but request successful" $ do
|
||||||
request $ do
|
request $ do
|
||||||
setMethod "GET"
|
setMethod "GET"
|
||||||
setUrl ("/sys/agent?spec=0.0.0" :: Text)
|
setUrl ("/sys/appmgr?spec=0.0.0" :: Text)
|
||||||
statusIs 200
|
statusIs 200
|
||||||
apps <- runDBtest $ selectList ([] :: [Filter SApp]) []
|
apps <- runDBtest $ selectList ([] :: [Filter SApp]) []
|
||||||
assertEq "no apps should exist" (length apps) 0
|
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"
|
"short desc lnd"
|
||||||
"long desc lnd"
|
"long desc lnd"
|
||||||
"png"
|
"png"
|
||||||
featuredCat <- runDBtest $ insert $ Category time FEATURED Nothing "desc"
|
featuredCat <- runDBtest $ insert $ Category time FEATURED Nothing "desc" 0
|
||||||
btcCat <- runDBtest $ insert $ Category time BITCOIN Nothing "desc"
|
btcCat <- runDBtest $ insert $ Category time BITCOIN Nothing "desc" 0
|
||||||
lnCat <- runDBtest $ insert $ Category time LIGHTNING Nothing "desc"
|
lnCat <- runDBtest $ insert $ Category time LIGHTNING Nothing "desc" 0
|
||||||
_ <- runDBtest $ insert_ $ ServiceCategory time btc featuredCat "bitcoin" FEATURED Nothing
|
_ <- runDBtest $ insert_ $ ServiceCategory time btc featuredCat "bitcoin" FEATURED Nothing
|
||||||
_ <- runDBtest $ insert_ $ ServiceCategory time lnd lnCat "lnd" LIGHTNING Nothing
|
_ <- runDBtest $ insert_ $ ServiceCategory time lnd lnCat "lnd" LIGHTNING Nothing
|
||||||
_ <- runDBtest $ insert_ $ ServiceCategory time lnd btcCat "lnd" BITCOIN Nothing
|
_ <- runDBtest $ insert_ $ ServiceCategory time lnd btcCat "lnd" BITCOIN Nothing
|
||||||
_ <- runDBtest $ insert_ $ ServiceCategory time btc btcCat "bitcon" 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
|
assertEq "should exist" (length apps) 1
|
||||||
let app' = fromJust $ head apps
|
let app' = fromJust $ head apps
|
||||||
assertEq "should be bitcoin" (sAppTitle $ entityVal app') "Bitcoin Core"
|
assertEq "should be bitcoin" (sAppTitle $ entityVal app') "Bitcoin Core"
|
||||||
@@ -60,14 +60,14 @@ spec = do
|
|||||||
"short desc lnd"
|
"short desc lnd"
|
||||||
"long desc lnd"
|
"long desc lnd"
|
||||||
"png"
|
"png"
|
||||||
featuredCat <- runDBtest $ insert $ Category time FEATURED Nothing "desc"
|
featuredCat <- runDBtest $ insert $ Category time FEATURED Nothing "desc" 0
|
||||||
btcCat <- runDBtest $ insert $ Category time BITCOIN Nothing "desc"
|
btcCat <- runDBtest $ insert $ Category time BITCOIN Nothing "desc" 0
|
||||||
lnCat <- runDBtest $ insert $ Category time LIGHTNING Nothing "desc"
|
lnCat <- runDBtest $ insert $ Category time LIGHTNING Nothing "desc" 0
|
||||||
_ <- runDBtest $ insert_ $ ServiceCategory time btc featuredCat "bitcoin" FEATURED Nothing
|
_ <- runDBtest $ insert_ $ ServiceCategory time btc featuredCat "bitcoind" FEATURED Nothing
|
||||||
_ <- runDBtest $ insert_ $ ServiceCategory time lnd lnCat "lnd" LIGHTNING Nothing
|
_ <- runDBtest $ insert_ $ ServiceCategory time lnd lnCat "lnd" LIGHTNING Nothing
|
||||||
_ <- runDBtest $ insert_ $ ServiceCategory time lnd btcCat "lnd" BITCOIN Nothing
|
_ <- runDBtest $ insert_ $ ServiceCategory time lnd btcCat "lnd" BITCOIN Nothing
|
||||||
_ <- runDBtest $ insert_ $ ServiceCategory time btc btcCat "bitcon" BITCOIN Nothing
|
_ <- runDBtest $ insert_ $ ServiceCategory time btc btcCat "bitcoind" BITCOIN Nothing
|
||||||
apps <- runDBtest $ searchServices BITCOIN 20 0 ""
|
apps <- runDBtest $ searchServices (Just BITCOIN) 20 0 ""
|
||||||
assertEq "should exist" (length apps) 2
|
assertEq "should exist" (length apps) 2
|
||||||
describe "searchServices with fuzzy query"
|
describe "searchServices with fuzzy query"
|
||||||
$ withApp
|
$ withApp
|
||||||
@@ -88,10 +88,10 @@ spec = do
|
|||||||
"short desc"
|
"short desc"
|
||||||
"lightning long desc"
|
"lightning long desc"
|
||||||
"png"
|
"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 app1 cate "bitcoind" FEATURED Nothing
|
||||||
_ <- runDBtest $ insert_ $ ServiceCategory time app2 cate "lnd" 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
|
assertEq "should exist" (length apps) 1
|
||||||
let app' = fromJust $ head apps
|
let app' = fromJust $ head apps
|
||||||
print app'
|
print app'
|
||||||
@@ -104,8 +104,9 @@ spec = do
|
|||||||
"short desc bitcoin"
|
"short desc bitcoin"
|
||||||
"long desc bitcoin"
|
"long desc bitcoin"
|
||||||
"png"
|
"png"
|
||||||
_ <- runDBtest $ insert $ SVersion time (Just time) btc "0.19.0" "notes" Any Any
|
print btc
|
||||||
_ <- runDBtest $ insert $ SVersion time (Just time) btc "0.20.0" "notes" Any Any
|
_ <- 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
|
lnd <- runDBtest $ insert $ SApp time
|
||||||
(Just time)
|
(Just time)
|
||||||
"Lightning Network Daemon"
|
"Lightning Network Daemon"
|
||||||
@@ -113,22 +114,23 @@ spec = do
|
|||||||
"short desc lnd"
|
"short desc lnd"
|
||||||
"long desc lnd"
|
"long desc lnd"
|
||||||
"png"
|
"png"
|
||||||
_ <- runDBtest $ insert $ SVersion time (Just time) lnd "0.18.0" "notes" Any Any
|
_ <- 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
|
_ <- runDBtest $ insert $ SVersion time (Just time) lnd "0.17.0" "notes" Any Any Nothing
|
||||||
featuredCat <- runDBtest $ insert $ Category time FEATURED Nothing "desc"
|
featuredCat <- runDBtest $ insert $ Category time FEATURED Nothing "desc" 0
|
||||||
btcCat <- runDBtest $ insert $ Category time BITCOIN Nothing "desc"
|
btcCat <- runDBtest $ insert $ Category time BITCOIN Nothing "desc" 0
|
||||||
lnCat <- runDBtest $ insert $ Category time LIGHTNING Nothing "desc"
|
lnCat <- runDBtest $ insert $ Category time LIGHTNING Nothing "desc" 0
|
||||||
_ <- runDBtest $ insert_ $ ServiceCategory time btc featuredCat "bitcoin" FEATURED Nothing
|
_ <- runDBtest $ insert_ $ ServiceCategory time btc featuredCat "bitcoin" FEATURED Nothing
|
||||||
_ <- runDBtest $ insert_ $ ServiceCategory time lnd lnCat "lnd" LIGHTNING Nothing
|
_ <- runDBtest $ insert_ $ ServiceCategory time lnd lnCat "lnd" LIGHTNING Nothing
|
||||||
_ <- runDBtest $ insert_ $ ServiceCategory time lnd btcCat "lnd" BITCOIN Nothing
|
_ <- runDBtest $ insert_ $ ServiceCategory time lnd btcCat "lnd" BITCOIN Nothing
|
||||||
_ <- runDBtest $ insert_ $ ServiceCategory time btc btcCat "bitcon" 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
|
assertEq "should exist" (length apps) 2
|
||||||
-- describe "getServiceVersionsWithReleaseNotes" $
|
xdescribe "getServiceVersionsWithReleaseNotes"
|
||||||
-- withApp $ it "gets service with mapping of version to release notes" $ do
|
$ withApp
|
||||||
-- time <- liftIO getCurrentTime
|
$ it "gets service with mapping of version to release notes"
|
||||||
-- app <- runDBtest $ insert $ SApp time Nothing "Bitcoin Core" "bitcoin" "short desc" "long desc" "png"
|
$ do
|
||||||
-- _ <- runDBtest $ insert $ SVersion time Nothing app "0.19.0.0" "release notes 0.19.0.0" "*" "*"
|
time <- liftIO getCurrentTime
|
||||||
-- _ <- runDBtest $ insert $ SVersion time Nothing app "0.20.0.0" "release notes 0.19.0.0" "*" "*"
|
app <- runDBtest $ insert $ SApp time Nothing "Bitcoin Core" "bitcoin" "short desc" "long desc" "png"
|
||||||
-- res <- runDBtest $ getServiceVersionsWithReleaseNotes "bitcoin"
|
_ <- runDBtest $ insert $ SVersion time Nothing app "0.19.0.0" "release notes 0.19.0.0" Any Any Nothing
|
||||||
-- print res
|
_ <- 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