Start9/registry
2
0
Fork 0
mirror of https://github.com/Start9Labs/registry.git synced 2026-03-26 02:11:53 +00:00
Code Issues Packages Projects Releases Wiki Activity

Feature/api versioning (#106)

Browse Source 
* wip

* finishes initial refactor

* prune unused code

* finished massive refactor

* remove commented deps

* fix import

* fix bug
This commit is contained in:
Keagan McClelland
2022-06-20 10:28:28 -06:00
committed by GitHub
parent bb0488f1dd
commit dbd73fae7f
44 changed files with 3115 additions and 3055 deletions
Download Patch File Download Diff File Expand all files Collapse all files

4
.gitignore vendored
View File

@@ -35,4 +35,6 @@ start9-registry.prof
start9-registry.hp start9-registry.hp
start9-registry.pdf start9-registry.pdf
start9-registry.aux start9-registry.aux
start9-registry.ps start9-registry.ps
shell.nix
testdata/

2
Makefile
View File

@@ -1,2 +1,4 @@
all: all:
stack build --local-bin-path dist --copy-bins stack build --local-bin-path dist --copy-bins
profile:
stack build --local-bin-path dist --copy-bins --profile

23
config/routes
View File

@@ -3,19 +3,16 @@
/eos/v0/eos.img EosR GET -- get eos.img /eos/v0/eos.img EosR GET -- get eos.img
-- PACKAGE API V0 -- PACKAGE API V0
/package/v0/info InfoR GET -- get all marketplace categories /package/#ApiVersion/info InfoR GET -- get all marketplace categories
/package/v0/index PackageListR GET -- filter marketplace services by various query params /package/#ApiVersion/index PackageIndexR GET -- filter marketplace services by various query params
/package/v0/latest VersionLatestR GET -- get latest version of apps in query param id /package/#ApiVersion/latest VersionLatestR GET -- get latest version of apps in query param id
!/package/v0/#S9PK AppR GET -- get most recent appId at appversion spec, defaults to >=0.0.0 -- ?spec=<emver> !/package/#ApiVersion/#S9PK AppR GET -- get most recent appId at appversion spec, defaults to >=0.0.0 -- ?spec=<emver>
/package/v0/manifest/#PkgId AppManifestR GET -- get app manifest from appmgr -- ?spec=<emver> /package/#ApiVersion/manifest/#PkgId AppManifestR GET -- get app manifest from appmgr -- ?spec=<emver>
/package/v0/release-notes/#PkgId ReleaseNotesR GET -- get release notes for all versions of a package /package/#ApiVersion/release-notes/#PkgId ReleaseNotesR GET -- get release notes for all versions of a package
/package/v0/icon/#PkgId IconsR GET -- get icons - can specify version with ?spec=<emver> /package/#ApiVersion/icon/#PkgId IconsR GET -- get icons - can specify version with ?spec=<emver>
/package/v0/license/#PkgId LicenseR GET -- get license - can specify version with ?spec=<emver> /package/#ApiVersion/license/#PkgId LicenseR GET -- get license - can specify version with ?spec=<emver>
/package/v0/instructions/#PkgId InstructionsR GET -- get instructions - can specify version with ?spec=<emver> /package/#ApiVersion/instructions/#PkgId InstructionsR GET -- get instructions - can specify version with ?spec=<emver>
/package/v0/version/#PkgId PkgVersionR GET -- get most recent appId version /package/#ApiVersion/version/#PkgId PkgVersionR GET -- get most recent appId version
-- SUPPORT API V0
/support/v0/error-logs ErrorLogsR POST
-- ADMIN API V0 -- ADMIN API V0
/admin/v0/upload PkgUploadR POST !admin /admin/v0/upload PkgUploadR POST !admin

8
fourmolu.yaml Normal file
View File

@@ -0,0 +1,8 @@
indentation: 4
comma-style: leading
record-brace-space: false
indent-wheres: true
diff-friendly-import-export: true
respectful: true
haddock-style: single-line
newlines-between-decls: 2

9
package.yaml
View File

@@ -2,15 +2,10 @@ name: start9-registry
version: 0.2.1 version: 0.2.1
default-extensions: default-extensions:
- FlexibleInstances
- GeneralizedNewtypeDeriving
- LambdaCase
- MultiWayIf
- NamedFieldPuns
- NoImplicitPrelude - NoImplicitPrelude
- NumericUnderscores - GHC2021
- LambdaCase
- OverloadedStrings - OverloadedStrings
- StandaloneDeriving
dependencies: dependencies:
- base >=4.12 && <5 - base >=4.12 && <5

667
src/Application.hs
View File

@@ -1,215 +1,227 @@
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-} {-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
module Application
( appMain module Application (
, develMain appMain,
, makeFoundation develMain,
, makeLogWare makeFoundation,
, shutdownApp makeLogWare,
, shutdownAll shutdownApp,
, shutdownWeb shutdownAll,
, startApp shutdownWeb,
, startWeb startApp,
startWeb,
-- * for DevelMain -- * for DevelMain
, getApplicationRepl getApplicationRepl,
, getAppSettings getAppSettings,
-- * for GHCI -- * for GHCI
, handler handler,
, db db,
) where ) where
import Startlude ( ($) import Startlude (
, (++) Applicative (pure),
, (.) Async (asyncThreadId),
, (<$>) Bool (False, True),
, (<||>) Either (Left, Right),
, Applicative(pure) Eq ((==)),
, Async(asyncThreadId) ExitCode (ExitSuccess),
, Bool(False, True) IO,
, Either(Left, Right) Int,
, Eq((==)) Maybe (Just),
, ExitCode(ExitSuccess) Monad (return, (>>=)),
, IO MonadIO (..),
, Int Print (putStr, putStrLn),
, Maybe(Just) ReaderT (runReaderT),
, Monad((>>=), return) Text,
, MonadIO(..) ThreadId,
, Print(putStr, putStrLn) async,
, ReaderT(runReaderT) flip,
, Text for_,
, ThreadId forever,
, async forkIO,
, flip fromIntegral,
, for_ killThread,
, forever newEmptyMVar,
, forkIO newMVar,
, fromIntegral onException,
, killThread panic,
, newEmptyMVar print,
, newMVar putMVar,
, onException show,
, panic stdout,
, print swapMVar,
, putMVar takeMVar,
, show void,
, stdout waitEitherCatchCancel,
, swapMVar when,
, takeMVar ($),
, void (++),
, waitEitherCatchCancel (.),
, when (<$>),
) (<||>),
)
import Control.Monad.Logger ( LoggingT import Control.Monad.Logger (
, liftLoc LoggingT,
, runLoggingT liftLoc,
) runLoggingT,
import Data.Default ( Default(def) ) )
import Database.Persist.Postgresql ( createPostgresqlPool import Data.Default (Default (def))
, pgConnStr import Database.Persist.Postgresql (
, pgPoolSize createPostgresqlPool,
, runMigration pgConnStr,
, runSqlPool pgPoolSize,
) runMigration,
import Language.Haskell.TH.Syntax ( qLocation ) runSqlPool,
import Network.Wai ( Application )
, Middleware import Language.Haskell.TH.Syntax (qLocation)
, Request(requestHeaders) import Network.Wai (
, ResponseReceived Application,
) Middleware,
import Network.Wai.Handler.Warp ( Settings Request (requestHeaders),
, defaultSettings ResponseReceived,
, defaultShouldDisplayException )
, getPort import Network.Wai.Handler.Warp (
, runSettings Settings,
, setHTTP2Disabled defaultSettings,
, setHost defaultShouldDisplayException,
, setOnException getPort,
, setPort runSettings,
, setTimeout setHTTP2Disabled,
) setHost,
import Network.Wai.Handler.WarpTLS ( runTLS setOnException,
, tlsSettings setPort,
) setTimeout,
import Network.Wai.Middleware.AcceptOverride )
( acceptOverride ) import Network.Wai.Handler.WarpTLS (
import Network.Wai.Middleware.Autohead runTLS,
( autohead ) tlsSettings,
import Network.Wai.Middleware.Cors ( CorsResourcePolicy(..) )
, cors import Network.Wai.Middleware.AcceptOverride (
, simpleCorsResourcePolicy acceptOverride,
) )
import Network.Wai.Middleware.MethodOverride import Network.Wai.Middleware.Autohead (
( methodOverride ) autohead,
import Network.Wai.Middleware.RequestLogger )
( Destination(Logger) import Network.Wai.Middleware.Cors (
, OutputFormat(..) CorsResourcePolicy (..),
, destination cors,
, mkRequestLogger simpleCorsResourcePolicy,
, outputFormat )
) import Network.Wai.Middleware.MethodOverride (
import System.IO ( BufferMode(..) methodOverride,
, hSetBuffering )
) import Network.Wai.Middleware.RequestLogger (
import System.Log.FastLogger ( defaultBufSize Destination (Logger),
, newStdoutLoggerSet OutputFormat (..),
, toLogStr destination,
) mkRequestLogger,
import Yesod.Core ( HandlerFor outputFormat,
, LogLevel(LevelError) )
, Yesod(messageLoggerSource) import System.IO (
, logInfo BufferMode (..),
, mkYesodDispatch hSetBuffering,
, toWaiAppPlain )
, typeOctet import System.Log.FastLogger (
) defaultBufSize,
import Yesod.Core.Types ( Logger(loggerSet) ) newStdoutLoggerSet,
import Yesod.Default.Config2 ( configSettingsYml toLogStr,
, develMainHelper )
, getDevSettings import Yesod.Core (
, loadYamlSettings HandlerFor,
, loadYamlSettingsArgs LogLevel (LevelError),
, makeYesodLogger Yesod (messageLoggerSource),
, useEnv logInfo,
) mkYesodDispatch,
toWaiAppPlain,
typeOctet,
)
import Yesod.Core.Types (Logger (loggerSet))
import Yesod.Default.Config2 (
configSettingsYml,
develMainHelper,
getDevSettings,
loadYamlSettings,
loadYamlSettingsArgs,
makeYesodLogger,
useEnv,
)
import Control.Lens (both)
import Data.List (lookup)
import Data.String.Interpolate.IsString (
i,
)
import Database.Persist.Migration qualified
import Database.Persist.Migration.Postgres qualified
import Database.Persist.Sql (SqlBackend)
import Foundation (
Handler,
RegistryCtx (..),
Route (..),
resourcesRegistryCtx,
setWebProcessThreadId,
unsafeHandler,
)
import Handler.Admin (
deleteCategoryR,
deletePkgCategorizeR,
getPkgDeindexR,
postCategoryR,
postPkgCategorizeR,
postPkgDeindexR,
postPkgIndexR,
postPkgUploadR,
)
import Handler.Eos (getEosR, getEosVersionR)
import Handler.Package
import Lib.PkgRepository (watchEosRepoRoot)
import Lib.Ssl (
doesSslNeedRenew,
renewSslCerts,
setupSsl,
)
import Migration (manualMigration)
import Model (migrateAll)
import Network.HTTP.Types.Header (hOrigin)
import Network.Wai.Middleware.Gzip (
GzipFiles (GzipCompress),
GzipSettings (gzipCheckMime, gzipFiles),
defaultCheckMime,
gzip,
)
import Network.Wai.Middleware.RequestLogger.JSON (
formatAsJSONWithHeaders,
)
import Settings (
AppPort,
AppSettings (..),
configSettingsYmlValue,
)
import System.Directory (createDirectoryIfMissing)
import System.Posix.Process (exitImmediately)
import System.Time.Extra (sleep)
import Yesod (YesodPersist (runDB))
import Control.Lens ( both )
import Data.List ( lookup )
import Data.String.Interpolate.IsString
( i )
import qualified Database.Persist.Migration
import qualified Database.Persist.Migration.Postgres
import Database.Persist.Sql ( SqlBackend )
import Foundation ( Handler
, RegistryCtx(..)
, Route(..)
, resourcesRegistryCtx
, setWebProcessThreadId
, unsafeHandler
)
import Handler.Admin ( deleteCategoryR
, deletePkgCategorizeR
, getPkgDeindexR
, postCategoryR
, postPkgCategorizeR
, postPkgDeindexR
, postPkgIndexR
, postPkgUploadR
)
import Handler.Apps ( getAppManifestR
, getAppR
)
import Handler.ErrorLogs ( postErrorLogsR )
import Handler.Icons ( getIconsR
, getInstructionsR
, getLicenseR
)
import Handler.Marketplace ( getEosR
, getEosVersionR
, getInfoR
, getPackageListR
, getReleaseNotesR
, getVersionLatestR
)
import Handler.Version ( getPkgVersionR )
import Lib.PkgRepository ( watchEosRepoRoot )
import Lib.Ssl ( doesSslNeedRenew
, renewSslCerts
, setupSsl
)
import Migration ( manualMigration )
import Model ( migrateAll )
import Network.HTTP.Types.Header ( hOrigin )
import Network.Wai.Middleware.Gzip ( GzipFiles(GzipCompress)
, GzipSettings(gzipCheckMime, gzipFiles)
, defaultCheckMime
, gzip
)
import Network.Wai.Middleware.RequestLogger.JSON
( formatAsJSONWithHeaders )
import Settings ( AppPort
, AppSettings(..)
, configSettingsYmlValue
)
import System.Directory ( createDirectoryIfMissing )
import System.Posix.Process ( exitImmediately )
import System.Time.Extra ( sleep )
import Yesod ( YesodPersist(runDB) )
-- This line actually creates our YesodDispatch instance. It is the second half -- 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
-- comments there for more details. -- comments there for more details.
mkYesodDispatch "RegistryCtx" resourcesRegistryCtx mkYesodDispatch "RegistryCtx" resourcesRegistryCtx
-- | This function allocates resources (such as a database connection pool), -- | This function allocates resources (such as a database connection pool),
-- performs initialization and returns a foundation datatype value. This is also -- performs initialization and returns a foundation datatype value. This is also
-- the place to put your migrate statements to have automatic database -- the place to put your migrate statements to have automatic database
@@ -218,20 +230,20 @@ 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 appStopFsNotifyEos = RegistryCtx { .. } let mkFoundation appConnPool appStopFsNotifyEos = 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 = tempFoundation =
mkFoundation (panic "connPool forced in tempFoundation") (panic "stopFsNotify forced in tempFoundation") mkFoundation (panic "connPool forced in tempFoundation") (panic "stopFsNotify forced in tempFoundation")
logFunc = messageLoggerSource tempFoundation appLogger logFunc = messageLoggerSource tempFoundation appLogger
@@ -239,8 +251,9 @@ makeFoundation appSettings = do
createDirectoryIfMissing True (errorLogRoot appSettings) createDirectoryIfMissing True (errorLogRoot appSettings)
-- Create the database connection pool -- Create the database connection pool
pool <- flip runLoggingT logFunc pool <-
$ createPostgresqlPool (pgConnStr $ appDatabaseConf appSettings) (pgPoolSize . appDatabaseConf $ appSettings) flip runLoggingT logFunc $
createPostgresqlPool (pgConnStr $ appDatabaseConf appSettings) (pgPoolSize . appDatabaseConf $ appSettings)
stopEosWatch <- runLoggingT (runReaderT (watchEosRepoRoot pool) appSettings) logFunc stopEosWatch <- runLoggingT (runReaderT (watchEosRepoRoot pool) appSettings) logFunc
@@ -253,6 +266,7 @@ makeFoundation appSettings = do
-- Return the foundation -- Return the foundation
return $ mkFoundation pool stopEosWatch return $ mkFoundation pool stopEosWatch
-- | 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.
makeApplication :: RegistryCtx -> IO Application makeApplication :: RegistryCtx -> IO Application
@@ -265,7 +279,7 @@ makeApplication foundation = do
-- TODO: change this to the cached version when we have better release processes -- TODO: change this to the cached version when we have better release processes
-- since caches aren't invalidated, publishing a new package/eos won't take effect -- since caches aren't invalidated, publishing a new package/eos won't take effect
-- because the cached file will be downloaded. -- because the cached file will be downloaded.
def { gzipFiles = GzipCompress, gzipCheckMime = defaultCheckMime <||> (== typeOctet) } def{gzipFiles = GzipCompress, gzipCheckMime = defaultCheckMime <||> (== typeOctet)}
pure pure
. logWare . logWare
. cors dynamicCorsResourcePolicy . cors dynamicCorsResourcePolicy
@@ -276,78 +290,86 @@ makeApplication foundation = do
. gzip gzipSettings . gzip gzipSettings
$ appPlain $ appPlain
dynamicCorsResourcePolicy :: Request -> Maybe CorsResourcePolicy dynamicCorsResourcePolicy :: Request -> Maybe CorsResourcePolicy
dynamicCorsResourcePolicy req = Just . policy . lookup hOrigin $ requestHeaders req dynamicCorsResourcePolicy req = Just . policy . lookup hOrigin $ requestHeaders req
where where
policy o = simpleCorsResourcePolicy policy o =
{ corsOrigins = (\o' -> ([o'], True)) <$> o simpleCorsResourcePolicy
, corsMethods = ["GET", "POST", "HEAD", "PUT", "DELETE", "TRACE", "CONNECT", "OPTIONS", "PATCH"] { corsOrigins = (\o' -> ([o'], True)) <$> o
, corsRequestHeaders = [ "app-version" , corsMethods = ["GET", "POST", "HEAD", "PUT", "DELETE", "TRACE", "CONNECT", "OPTIONS", "PATCH"]
, "Accept" , corsRequestHeaders =
, "Accept-Charset" [ "app-version"
, "Accept-Encoding" , "Accept"
, "Accept-Language" , "Accept-Charset"
, "Accept-Ranges" , "Accept-Encoding"
, "Age" , "Accept-Language"
, "Allow" , "Accept-Ranges"
, "Authorization" , "Age"
, "Cache-Control" , "Allow"
, "Connection" , "Authorization"
, "Content-Encoding" , "Cache-Control"
, "Content-Language" , "Connection"
, "Content-Length" , "Content-Encoding"
, "Content-Location" , "Content-Language"
, "Content-MD5" , "Content-Length"
, "Content-Range" , "Content-Location"
, "Content-Type" , "Content-MD5"
, "Date" , "Content-Range"
, "ETag" , "Content-Type"
, "Expect" , "Date"
, "Expires" , "ETag"
, "From" , "Expect"
, "Host" , "Expires"
, "If-Match" , "From"
, "If-Modified-Since" , "Host"
, "If-None-Match" , "If-Match"
, "If-Range" , "If-Modified-Since"
, "If-Unmodified-Since" , "If-None-Match"
, "Last-Modified" , "If-Range"
, "Location" , "If-Unmodified-Since"
, "Max-Forwards" , "Last-Modified"
, "Pragma" , "Location"
, "Proxy-Authenticate" , "Max-Forwards"
, "Proxy-Authorization" , "Pragma"
, "Range" , "Proxy-Authenticate"
, "Referer" , "Proxy-Authorization"
, "Retry-After" , "Range"
, "Server" , "Referer"
, "TE" , "Retry-After"
, "Trailer" , "Server"
, "Transfer-Encoding" , "TE"
, "Upgrade" , "Trailer"
, "User-Agent" , "Transfer-Encoding"
, "Vary" , "Upgrade"
, "Via" , "User-Agent"
, "WWW-Authenticate" , "Vary"
, "Warning" , "Via"
, "Content-Disposition" , "WWW-Authenticate"
, "MIME-Version" , "Warning"
, "Cookie" , "Content-Disposition"
, "Set-Cookie" , "MIME-Version"
, "Origin" , "Cookie"
, "Prefer" , "Set-Cookie"
, "Preference-Applied" , "Origin"
] , "Prefer"
, corsIgnoreFailures = True , "Preference-Applied"
} ]
, corsIgnoreFailures = True
}
makeLogWare :: RegistryCtx -> IO Middleware makeLogWare :: RegistryCtx -> IO Middleware
makeLogWare foundation = mkRequestLogger def makeLogWare foundation =
{ outputFormat = if appDetailedRequestLogging $ appSettings foundation mkRequestLogger
then Detailed True def
else CustomOutputFormatWithDetailsAndHeaders formatAsJSONWithHeaders { outputFormat =
, destination = Logger $ loggerSet $ appLogger foundation if appDetailedRequestLogging $ appSettings foundation
} then Detailed True
else CustomOutputFormatWithDetailsAndHeaders formatAsJSONWithHeaders
, destination = Logger $ loggerSet $ appLogger foundation
}
makeAuthWare :: RegistryCtx -> Middleware makeAuthWare :: RegistryCtx -> Middleware
makeAuthWare _ app req res = next makeAuthWare _ app req res = next
@@ -355,40 +377,47 @@ makeAuthWare _ app req res = next
next :: IO ResponseReceived next :: IO ResponseReceived
next = app req res next = app req res
-- | Warp settings for the given foundation value. -- | Warp settings for the given foundation value.
warpSettings :: AppPort -> RegistryCtx -> Settings warpSettings :: AppPort -> RegistryCtx -> Settings
warpSettings port foundation = warpSettings port foundation =
setTimeout 60 setTimeout 60 $
$ setPort (fromIntegral port) setPort (fromIntegral port) $
$ setHost (appHost $ appSettings foundation) setHost (appHost $ appSettings foundation) $
$ setOnException (\_req e -> setOnException
when (defaultShouldDisplayException e) $ messageLoggerSource ( \_req e ->
foundation when (defaultShouldDisplayException e) $
(appLogger foundation) messageLoggerSource
$(qLocation >>= liftLoc) foundation
"yesod" (appLogger foundation)
LevelError $(qLocation >>= liftLoc)
(toLogStr $ "Exception from Warp: " ++ show e)) "yesod"
(setHTTP2Disabled defaultSettings) LevelError
(toLogStr $ "Exception from Warp: " ++ show e)
)
(setHTTP2Disabled defaultSettings)
getAppSettings :: IO AppSettings getAppSettings :: IO AppSettings
getAppSettings = loadYamlSettings [configSettingsYml] [] useEnv getAppSettings = loadYamlSettings [configSettingsYml] [] useEnv
-- | The @main@ function for an executable running this site. -- | The @main@ function for an executable running this site.
appMain :: IO () appMain :: IO ()
appMain = do appMain = do
hSetBuffering stdout LineBuffering hSetBuffering stdout LineBuffering
-- Get the settings from all relevant sources -- Get the settings from all relevant sources
settings <- loadYamlSettingsArgs settings <-
-- fall back to compile-time values, set to [] to require values at runtime loadYamlSettingsArgs
[configSettingsYmlValue] -- fall back to compile-time values, set to [] to require values at runtime
[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
startApp :: RegistryCtx -> IO () startApp :: RegistryCtx -> IO ()
startApp foundation = do startApp foundation = do
when (sslAuto . appSettings $ foundation) $ do when (sslAuto . appSettings $ foundation) $ do
@@ -398,33 +427,38 @@ startApp foundation = do
runLog $ $logInfo "SSL Setup Complete" runLog $ $logInfo "SSL Setup Complete"
-- certbot renew loop -- certbot renew loop
void . forkIO $ forever $ flip runReaderT foundation $ do void . forkIO $
shouldRenew <- doesSslNeedRenew forever $
runLog $ $logInfo [i|Checking if SSL Certs should be renewed: #{shouldRenew}|] flip runReaderT foundation $ do
when shouldRenew $ do shouldRenew <- doesSslNeedRenew
runLog $ $logInfo "Renewing SSL Certs." runLog $ $logInfo [i|Checking if SSL Certs should be renewed: #{shouldRenew}|]
renewSslCerts when shouldRenew $ do
liftIO $ restartWeb foundation runLog $ $logInfo "Renewing SSL Certs."
liftIO $ sleep 86_400 renewSslCerts
liftIO $ restartWeb foundation
liftIO $ sleep 86_400
startWeb foundation startWeb foundation
where where
runLog :: MonadIO m => LoggingT m a -> m a runLog :: MonadIO m => LoggingT m a -> m a
runLog a = runLoggingT a (messageLoggerSource foundation (appLogger foundation)) 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 = (`onException` appStopFsNotifyEos foundation) $ do startWeb' app = (`onException` appStopFsNotifyEos foundation) $ do
let AppSettings {..} = appSettings foundation let AppSettings{..} = appSettings foundation
runLog $ $logInfo [i|Launching Tor Web Server on port #{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
runLog $ $logInfo [i|Launching Web Server on port #{appPort}|] runLog $ $logInfo [i|Launching Web Server on port #{appPort}|]
action <- async $ if sslAuto action <-
then runTLS (tlsSettings sslCertLocation sslKeyLocation) (warpSettings appPort foundation) app async $
else runSettings (warpSettings appPort foundation) app if sslAuto
then runTLS (tlsSettings sslCertLocation sslKeyLocation) (warpSettings appPort foundation) app
else runSettings (warpSettings appPort foundation) app
setWebProcessThreadId (asyncThreadId action, asyncThreadId torAction) foundation setWebProcessThreadId (asyncThreadId action, asyncThreadId torAction) foundation
res <- waitEitherCatchCancel action torAction res <- waitEitherCatchCancel action torAction
@@ -450,52 +484,60 @@ startWeb foundation = do
startWeb' app startWeb' app
runLog a = runLoggingT a (messageLoggerSource foundation (appLogger foundation)) runLog a = runLoggingT a (messageLoggerSource foundation (appLogger foundation))
restartWeb :: RegistryCtx -> IO () restartWeb :: RegistryCtx -> IO ()
restartWeb foundation = do restartWeb foundation = do
void $ swapMVar (appShouldRestartWeb foundation) True void $ swapMVar (appShouldRestartWeb foundation) True
shutdownWeb foundation shutdownWeb foundation
shutdownAll :: [ThreadId] -> IO () shutdownAll :: [ThreadId] -> IO ()
shutdownAll threadIds = do shutdownAll threadIds = do
for_ threadIds killThread for_ threadIds killThread
exitImmediately ExitSuccess exitImmediately ExitSuccess
-- 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 ()
-- | 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
develMain :: IO () develMain :: IO ()
develMain = do develMain = do
settings <- getAppSettings settings <- getAppSettings
develMainHelper $ getApplicationDev $ appPort settings develMainHelper $ getApplicationDev $ appPort settings
--------------------------------------------- ---------------------------------------------
-- Functions for use in development with GHCi -- Functions for use in development with GHCi
--------------------------------------------- ---------------------------------------------
@@ -504,6 +546,7 @@ develMain = do
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 -- | Run DB queries
db :: ReaderT SqlBackend (HandlerFor RegistryCtx) a -> IO a db :: ReaderT SqlBackend (HandlerFor RegistryCtx) a -> IO a
db = handler . runDB db = handler . runDB

647
src/Cli/Cli.hs
View File

@@ -8,199 +8,217 @@
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -Wno-orphans #-}
module Cli.Cli module Cli.Cli (
( cliMain cliMain,
) where ) where
import Conduit (
foldC,
runConduit,
(.|),
)
import Control.Monad.Logger (
LogLevel (..),
MonadLogger (monadLoggerLog),
MonadLoggerIO (askLoggerIO),
ToLogStr,
fromLogStr,
toLogStr,
)
import Crypto.Hash (
SHA256 (SHA256),
hashWith,
)
import Data.Aeson (
ToJSON,
eitherDecodeStrict,
)
import Data.ByteArray.Encoding (
Base (..),
convertToBase,
)
import Data.ByteString.Char8 qualified as B8
import Data.ByteString.Lazy qualified as LB
import Data.Conduit.Process (readProcess)
import Data.Default
import Data.Functor.Contravariant (contramap)
import Data.HashMap.Internal.Strict (
HashMap,
delete,
empty,
insert,
lookup,
traverseWithKey,
)
import Data.String.Interpolate.IsString (
i,
)
import Data.Text (toLower)
import Dhall (
Encoder (embed),
FromDhall (..),
Generic,
ToDhall (..),
auto,
inject,
inputFile,
)
import Dhall.Core (pretty)
import Handler.Admin (
AddCategoryReq (AddCategoryReq),
IndexPkgReq (IndexPkgReq),
PackageList (..),
)
import Lib.External.AppMgr (sourceManifest)
import Lib.Types.Core (
PkgId (..),
)
import Lib.Types.Emver (Version (..))
import Lib.Types.Manifest (PackageManifest (..))
import Network.HTTP.Client.Conduit (
StreamFileStatus (StreamFileStatus, fileSize, readSoFar),
applyBasicAuth,
httpLbs,
observedStreamFile,
)
import Network.HTTP.Client.TLS (newTlsManager)
import Network.HTTP.Simple (
getResponseBody,
getResponseStatus,
httpJSON,
httpLBS,
parseRequest,
setRequestBody,
setRequestBodyJSON,
setRequestHeaders,
)
import Network.HTTP.Types (status200)
import Network.URI (
URI,
parseURI,
)
import Options.Applicative (
Alternative ((<|>)),
Applicative (liftA2, pure, (<*>)),
Parser,
ParserInfo,
auto,
command,
execParser,
fullDesc,
help,
helper,
info,
liftA3,
long,
mappend,
metavar,
option,
optional,
progDesc,
short,
strArgument,
strOption,
subparser,
switch,
(<$>),
(<**>),
)
import Rainbow (
Chunk,
Radiant,
blue,
chunk,
fore,
green,
magenta,
putChunk,
putChunkLn,
red,
white,
yellow,
)
import Startlude (
Bool (..),
ConvertText (toS),
Either (..),
Eq (..),
ExitCode (..),
FilePath,
IO,
Int,
IsString (..),
Maybe (..),
Monad ((>>=)),
ReaderT (runReaderT),
Semigroup ((<>)),
Show,
String,
appendFile,
const,
decodeUtf8,
exitWith,
filter,
flip,
fmap,
for,
for_,
fromIntegral,
fromMaybe,
fst,
headMay,
not,
panic,
show,
snd,
unlessM,
void,
when,
writeFile,
zip,
($),
($>),
(&),
(.),
(<&>),
)
import System.Directory (
createDirectoryIfMissing,
doesPathExist,
getCurrentDirectory,
getFileSize,
getHomeDirectory,
listDirectory,
)
import System.FilePath (
takeDirectory,
takeExtension,
(</>),
)
import System.ProgressBar (
Progress (..),
defStyle,
newProgressBar,
updateProgress,
)
import Yesod (
logError,
logWarn,
)
import Conduit ( (.|)
, foldC
, runConduit
)
import Control.Monad.Logger ( LogLevel(..)
, MonadLogger(monadLoggerLog)
, MonadLoggerIO(askLoggerIO)
, ToLogStr
, fromLogStr
, toLogStr
)
import Crypto.Hash ( SHA256(SHA256)
, hashWith
)
import Data.Aeson ( ToJSON
, eitherDecodeStrict
)
import Data.ByteArray.Encoding ( Base(..)
, convertToBase
)
import qualified Data.ByteString.Char8 as B8
import qualified Data.ByteString.Lazy as LB
import Data.Conduit.Process ( readProcess )
import Data.Default
import Data.Functor.Contravariant ( contramap )
import Data.HashMap.Internal.Strict ( HashMap
, delete
, empty
, insert
, lookup
, traverseWithKey
)
import Data.String.Interpolate.IsString
( i )
import Data.Text ( toLower )
import Dhall ( Encoder(embed)
, FromDhall(..)
, Generic
, ToDhall(..)
, auto
, inject
, inputFile
)
import Dhall.Core ( pretty )
import Handler.Admin ( AddCategoryReq(AddCategoryReq)
, IndexPkgReq(IndexPkgReq)
, PackageList(..)
)
import Lib.External.AppMgr ( sourceManifest )
import Lib.Types.AppIndex ( PackageManifest
( PackageManifest
, packageManifestId
, packageManifestVersion
)
, PkgId(..)
)
import Lib.Types.Emver ( Version(..) )
import Network.HTTP.Client.Conduit ( StreamFileStatus(StreamFileStatus, fileSize, readSoFar)
, applyBasicAuth
, httpLbs
, observedStreamFile
)
import Network.HTTP.Client.TLS ( newTlsManager )
import Network.HTTP.Simple ( getResponseBody
, getResponseStatus
, httpJSON
, httpLBS
, parseRequest
, setRequestBody
, setRequestBodyJSON
, setRequestHeaders
)
import Network.HTTP.Types ( status200 )
import Network.URI ( URI
, parseURI
)
import Options.Applicative ( (<$>)
, (<**>)
, Alternative((<|>))
, Applicative((<*>), liftA2, pure)
, Parser
, ParserInfo
, auto
, command
, execParser
, fullDesc
, help
, helper
, info
, liftA3
, long
, mappend
, metavar
, option
, optional
, progDesc
, short
, strArgument
, strOption
, subparser
, switch
)
import Rainbow ( Chunk
, Radiant
, blue
, chunk
, fore
, green
, magenta
, putChunk
, putChunkLn
, red
, white
, yellow
)
import Startlude ( ($)
, ($>)
, (&)
, (.)
, (<&>)
, Bool(..)
, ConvertText(toS)
, Either(..)
, Eq(..)
, ExitCode(..)
, FilePath
, IO
, Int
, IsString(..)
, Maybe(..)
, Monad((>>=))
, ReaderT(runReaderT)
, Semigroup((<>))
, Show
, String
, appendFile
, const
, decodeUtf8
, exitWith
, filter
, flip
, fmap
, for
, for_
, fromIntegral
, fromMaybe
, fst
, headMay
, not
, panic
, show
, snd
, unlessM
, void
, when
, writeFile
, zip
)
import System.Directory ( createDirectoryIfMissing
, doesPathExist
, getCurrentDirectory
, getFileSize
, getHomeDirectory
, listDirectory
)
import System.FilePath ( (</>)
, takeDirectory
, takeExtension
)
import System.ProgressBar ( Progress(..)
, defStyle
, newProgressBar
, updateProgress
)
import Yesod ( logError
, logWarn
)
data Upload = Upload data Upload = Upload
{ publishRepoName :: !String { publishRepoName :: !String
, publishPkg :: !(Maybe FilePath) , publishPkg :: !(Maybe FilePath)
, publishIndex :: !Bool , publishIndex :: !Bool
} }
deriving Show deriving (Show)
newtype PublishCfg = PublishCfg newtype PublishCfg = PublishCfg
{ publishCfgRepos :: HashMap String PublishCfgRepo { publishCfgRepos :: HashMap String PublishCfgRepo
} }
deriving Generic deriving (Generic)
instance FromDhall PublishCfg instance FromDhall PublishCfg
instance ToDhall PublishCfg instance ToDhall PublishCfg
instance Default PublishCfg where instance Default PublishCfg where
@@ -209,23 +227,27 @@ instance Default PublishCfg where
data PublishCfgRepo = PublishCfgRepo data PublishCfgRepo = PublishCfgRepo
{ publishCfgRepoLocation :: !URI { publishCfgRepoLocation :: !URI
, publishCfgRepoUser :: !String , publishCfgRepoUser :: !String
, publishCfgRepoPass :: !String , publishCfgRepoPass :: !String
} }
deriving (Show, Generic) deriving (Show, Generic)
instance FromDhall PublishCfgRepo instance FromDhall PublishCfgRepo
instance ToDhall PublishCfgRepo instance ToDhall PublishCfgRepo
instance FromDhall URI where instance FromDhall URI where
autoWith norm = fromMaybe (panic "Invalid URI for publish target") . parseURI <$> autoWith norm autoWith norm = fromMaybe (panic "Invalid URI for publish target") . parseURI <$> autoWith norm
instance ToDhall URI where instance ToDhall URI where
injectWith norm = contramap (show @_ @String) (injectWith norm) injectWith norm = contramap (show @_ @String) (injectWith norm)
instance IsString URI where instance IsString URI where
fromString = fromMaybe (panic "Invalid URI for publish target") . parseURI fromString = fromMaybe (panic "Invalid URI for publish target") . parseURI
data Shell = Bash | Fish | Zsh deriving Show
data Shell = Bash | Fish | Zsh deriving (Show)
data Command data Command
= CmdInit !(Maybe Shell) = CmdInit !(Maybe Shell)
| CmdRegAdd !String !PublishCfgRepo | CmdRegAdd !String !PublishCfgRepo
@@ -238,72 +260,89 @@ data Command
| CmdCatDel !String !String | CmdCatDel !String !String
| CmdPkgCatAdd !String !PkgId !String | CmdPkgCatAdd !String !PkgId !String
| CmdPkgCatDel !String !PkgId !String | CmdPkgCatDel !String !PkgId !String
deriving Show deriving (Show)
cfgLocation :: IO FilePath cfgLocation :: IO FilePath
cfgLocation = getHomeDirectory <&> \d -> d </> ".embassy/publish.dhall" cfgLocation = getHomeDirectory <&> \d -> d </> ".embassy/publish.dhall"
parseInit :: Parser (Maybe Shell) parseInit :: Parser (Maybe Shell)
parseInit = subparser $ command "init" (info go $ progDesc "Initializes embassy-publish config") <> metavar "init" parseInit = subparser $ command "init" (info go $ progDesc "Initializes embassy-publish config") <> metavar "init"
where where
shells = [Bash, Fish, Zsh] shells = [Bash, Fish, Zsh]
go = headMay . fmap fst . filter snd . zip shells <$> for shells (switch . long . toS . toLower . show) go = headMay . fmap fst . filter snd . zip shells <$> for shells (switch . long . toS . toLower . show)
parsePublish :: Parser Upload parsePublish :: Parser Upload
parsePublish = subparser $ command "upload" (info go $ progDesc "Publishes a .s9pk to a remote registry") <> metavar parsePublish =
"upload" subparser $
command "upload" (info go $ progDesc "Publishes a .s9pk to a remote registry")
<> metavar
"upload"
where where
go = liftA3 go =
Upload liftA3
(strOption (short 't' <> long "target" <> metavar "NAME" <> help "Name of registry in publish.dhall")) Upload
(optional $ strOption (strOption (short 't' <> long "target" <> metavar "NAME" <> help "Name of registry in publish.dhall"))
(short 'p' <> long "package" <> metavar "S9PK" <> help "File path of the package to publish") ( optional $
) strOption
(switch (short 'i' <> long "index" <> help "Index the package after uploading")) (short 'p' <> long "package" <> metavar "S9PK" <> help "File path of the package to publish")
)
(switch (short 'i' <> long "index" <> help "Index the package after uploading"))
parseRepoAdd :: Parser Command parseRepoAdd :: Parser Command
parseRepoAdd = subparser $ command "add" (info go $ progDesc "Add a registry to your config") <> metavar "add" parseRepoAdd = subparser $ command "add" (info go $ progDesc "Add a registry to your config") <> metavar "add"
where where
go :: Parser Command go :: Parser Command
go = go =
let let publishCfgRepoLocation =
publishCfgRepoLocation =
strOption (short 'l' <> long "location" <> metavar "REGISTRY_URL" <> help "Registry URL") strOption (short 'l' <> long "location" <> metavar "REGISTRY_URL" <> help "Registry URL")
publishCfgRepoUser = strOption publishCfgRepoUser =
(short 'u' <> long "username" <> metavar "USERNAME" <> help "Admin username for this registry") strOption
publishCfgRepoPass = strOption (short 'u' <> long "username" <> metavar "USERNAME" <> help "Admin username for this registry")
(short 'p' <> long "password" <> metavar "PASSWORD" <> help "Admin password for this registry") publishCfgRepoPass =
strOption
(short 'p' <> long "password" <> metavar "PASSWORD" <> help "Admin password for this registry")
name = name =
strOption strOption
(short 'n' <> long "name" <> metavar "REGISTRY_NAME" <> help ( short 'n' <> long "name" <> metavar "REGISTRY_NAME"
"Name to reference this registry in the future" <> help
"Name to reference this registry in the future"
) )
r = PublishCfgRepo <$> publishCfgRepoLocation <*> publishCfgRepoUser <*> publishCfgRepoPass r = PublishCfgRepo <$> publishCfgRepoLocation <*> publishCfgRepoUser <*> publishCfgRepoPass
in in liftA2 CmdRegAdd name r
liftA2 CmdRegAdd name r
parseRepoDel :: Parser String parseRepoDel :: Parser String
parseRepoDel = subparser $ command "rm" (info go $ progDesc "Remove a registry from your config") <> metavar "rm" parseRepoDel = subparser $ command "rm" (info go $ progDesc "Remove a registry from your config") <> metavar "rm"
where where
go = strOption go =
(short 'n' <> long "name" <> metavar "REGISTRY_NAME" <> help strOption
"Registry name chosen when this was originally configured" ( short 'n' <> long "name" <> metavar "REGISTRY_NAME"
) <> help
"Registry name chosen when this was originally configured"
)
parseRepoList :: Parser () parseRepoList :: Parser ()
parseRepoList = subparser $ command "ls" (info (pure ()) $ progDesc "List registries in your config") <> metavar "ls" parseRepoList = subparser $ command "ls" (info (pure ()) $ progDesc "List registries in your config") <> metavar "ls"
parseIndex :: Parser Command parseIndex :: Parser Command
parseIndex = parseIndex =
subparser subparser $
$ command "index" (info (parseIndexHelper True) $ progDesc "Indexes an existing package version") command "index" (info (parseIndexHelper True) $ progDesc "Indexes an existing package version")
<> metavar "index" <> metavar "index"
parseDeindex :: Parser Command parseDeindex :: Parser Command
parseDeindex = parseDeindex =
subparser subparser $
$ command "deindex" (info (parseIndexHelper False) $ progDesc "Deindexes an existing package version") command "deindex" (info (parseIndexHelper False) $ progDesc "Deindexes an existing package version")
<> metavar "deindex" <> metavar "deindex"
parseIndexHelper :: Bool -> Parser Command parseIndexHelper :: Bool -> Parser Command
parseIndexHelper b = parseIndexHelper b =
@@ -313,12 +352,16 @@ parseIndexHelper b =
<*> strArgument (metavar "VERSION") <*> strArgument (metavar "VERSION")
<*> pure b <*> pure b
parseListUnindexed :: Parser String parseListUnindexed :: Parser String
parseListUnindexed = subparser $ command parseListUnindexed =
"list-unindexed" subparser $
( info (strOption (short 't' <> long "target" <> metavar "REGISTRY_NAME")) command
$ progDesc "Lists unindexed package versions on target registry" "list-unindexed"
) ( info (strOption (short 't' <> long "target" <> metavar "REGISTRY_NAME")) $
progDesc "Lists unindexed package versions on target registry"
)
parseCommand :: Parser Command parseCommand :: Parser Command
parseCommand = parseCommand =
@@ -330,31 +373,39 @@ parseCommand =
<|> (CmdListUnindexed <$> parseListUnindexed) <|> (CmdListUnindexed <$> parseListUnindexed)
<|> parseCat <|> parseCat
<|> parsePkgCat <|> parsePkgCat
where reg = parseRepoAdd <|> (CmdRegDel <$> parseRepoDel) <|> (parseRepoList $> CmdRegList) where
reg = parseRepoAdd <|> (CmdRegDel <$> parseRepoDel) <|> (parseRepoList $> CmdRegList)
parseCat :: Parser Command parseCat :: Parser Command
parseCat = subparser $ command "category" (info (add <|> del) $ progDesc "Manage categories") parseCat = subparser $ command "category" (info (add <|> del) $ progDesc "Manage categories")
where where
add = subparser $ command add =
"add" subparser $
( info command
( CmdCatAdd "add"
<$> strOption (short 't' <> long "target" <> metavar "REGISTRY_NAME") ( info
<*> strArgument (metavar "CATEGORY") ( CmdCatAdd
<*> optional (strOption (short 'd' <> long "description" <> metavar "DESCRIPTION")) <$> strOption (short 't' <> long "target" <> metavar "REGISTRY_NAME")
<*> optional <*> strArgument (metavar "CATEGORY")
(option Options.Applicative.auto (short 'p' <> long "priority" <> metavar "PRIORITY")) <*> optional (strOption (short 'd' <> long "description" <> metavar "DESCRIPTION"))
<*> optional
(option Options.Applicative.auto (short 'p' <> long "priority" <> metavar "PRIORITY"))
)
$ progDesc "Adds category to registry"
) )
$ progDesc "Adds category to registry" del =
) subparser $
del = subparser $ command command
"rm" "rm"
( info ( info
(CmdCatDel <$> strOption (short 't' <> long "target" <> metavar "REGISTRY_NAME") <*> strArgument ( CmdCatDel <$> strOption (short 't' <> long "target" <> metavar "REGISTRY_NAME")
(metavar "CATEGORY") <*> strArgument
(metavar "CATEGORY")
)
$ progDesc "Removes category from registry"
) )
$ progDesc "Removes category from registry"
)
parsePkgCat :: Parser Command parsePkgCat :: Parser Command
parsePkgCat = subparser $ command "categorize" (info cat $ progDesc "Add or remove package from category") parsePkgCat = subparser $ command "categorize" (info cat $ progDesc "Add or remove package from category")
@@ -362,28 +413,32 @@ parsePkgCat = subparser $ command "categorize" (info cat $ progDesc "Add or remo
cat :: Parser Command cat :: Parser Command
cat = cat =
let cmd rm = if not rm then CmdPkgCatAdd else CmdPkgCatDel let cmd rm = if not rm then CmdPkgCatAdd else CmdPkgCatDel
in cmd in cmd
<$> switch (long "remove") <$> switch (long "remove")
<*> strOption (short 't' <> long "target" <> metavar "REGISTRY_NAME") <*> strOption (short 't' <> long "target" <> metavar "REGISTRY_NAME")
<*> strArgument (metavar "PACKAGE_ID") <*> strArgument (metavar "PACKAGE_ID")
<*> strArgument (metavar "CATEGORY") <*> strArgument (metavar "CATEGORY")
opts :: ParserInfo Command opts :: ParserInfo Command
opts = info (parseCommand <**> helper) (fullDesc <> progDesc "Publish tool for Embassy Packages") opts = info (parseCommand <**> helper) (fullDesc <> progDesc "Publish tool for Embassy Packages")
cliMain :: IO () cliMain :: IO ()
cliMain = execParser opts >>= \case cliMain =
CmdInit sh -> init sh execParser opts >>= \case
CmdRegAdd s pcr -> regAdd s pcr CmdInit sh -> init sh
CmdRegDel s -> regRm s CmdRegAdd s pcr -> regAdd s pcr
CmdRegList -> regLs CmdRegDel s -> regRm s
CmdUpload up -> upload up CmdRegList -> regLs
CmdIndex name pkg v shouldIndex -> if shouldIndex then index name pkg v else deindex name pkg v CmdUpload up -> upload up
CmdListUnindexed name -> listUnindexed name CmdIndex name pkg v shouldIndex -> if shouldIndex then index name pkg v else deindex name pkg v
CmdCatAdd target cat desc pri -> catAdd target cat desc pri CmdListUnindexed name -> listUnindexed name
CmdCatDel target cat -> catDel target cat CmdCatAdd target cat desc pri -> catAdd target cat desc pri
CmdPkgCatAdd target pkg cat -> pkgCatAdd target pkg cat CmdCatDel target cat -> catDel target cat
CmdPkgCatDel target pkg cat -> pkgCatDel target pkg cat CmdPkgCatAdd target pkg cat -> pkgCatAdd target pkg cat
CmdPkgCatDel target pkg cat -> pkgCatDel target pkg cat
init :: Maybe Shell -> IO () init :: Maybe Shell -> IO ()
init sh = do init sh = do
@@ -405,10 +460,9 @@ init sh = do
writeFile zshcompleter (toS res) writeFile zshcompleter (toS res)
regAdd :: String -> PublishCfgRepo -> IO () regAdd :: String -> PublishCfgRepo -> IO ()
regAdd name val = do regAdd name val = do
loc <- cfgLocation loc <- cfgLocation
PublishCfg cfg <- inputFile Dhall.auto loc PublishCfg cfg <- inputFile Dhall.auto loc
let cfg' = insert name val cfg let cfg' = insert name val cfg
writeFile loc (pretty $ embed inject $ PublishCfg cfg') writeFile loc (pretty $ embed inject $ PublishCfg cfg')
@@ -423,16 +477,18 @@ regAdd name val = do
. mappend "start9_admin:" . mappend "start9_admin:"
$ publishCfgRepoPass val $ publishCfgRepoPass val
regRm :: String -> IO () regRm :: String -> IO ()
regRm name = do regRm name = do
loc <- cfgLocation loc <- cfgLocation
PublishCfg cfg <- inputFile Dhall.auto loc PublishCfg cfg <- inputFile Dhall.auto loc
let cfg' = delete name cfg let cfg' = delete name cfg
writeFile loc (pretty $ embed inject $ PublishCfg cfg') writeFile loc (pretty $ embed inject $ PublishCfg cfg')
regLs :: IO () regLs :: IO ()
regLs = do regLs = do
loc <- cfgLocation loc <- cfgLocation
PublishCfg cfg <- inputFile Dhall.auto loc PublishCfg cfg <- inputFile Dhall.auto loc
void $ traverseWithKey f cfg void $ traverseWithKey f cfg
where where
@@ -440,19 +496,20 @@ regLs = do
putChunk $ fromString (k <> ": ") & fore yellow putChunk $ fromString (k <> ": ") & fore yellow
putChunkLn $ fromString (show $ publishCfgRepoLocation v) & fore magenta putChunkLn $ fromString (show $ publishCfgRepoLocation v) & fore magenta
upload :: Upload -> IO () upload :: Upload -> IO ()
upload (Upload name mpkg shouldIndex) = do upload (Upload name mpkg shouldIndex) = do
PublishCfgRepo {..} <- findNameInCfg name PublishCfgRepo{..} <- findNameInCfg name
pkg <- case mpkg of pkg <- case mpkg of
Nothing -> do Nothing -> do
cwd <- getCurrentDirectory cwd <- getCurrentDirectory
files <- listDirectory cwd files <- listDirectory cwd
let pkgs = filter (\n -> takeExtension n == ".s9pk") files let pkgs = filter (\n -> takeExtension n == ".s9pk") files
case pkgs of case pkgs of
[] -> do [] -> do
$logError "No package specified, and could not find one in this directory" $logError "No package specified, and could not find one in this directory"
exitWith $ ExitFailure 1 exitWith $ ExitFailure 1
[p ] -> pure (cwd </> p) [p] -> pure (cwd </> p)
(_ : _ : _) -> do (_ : _ : _) -> do
$logWarn "Ambiguous package upload request, found multiple candidates:" $logWarn "Ambiguous package upload request, found multiple candidates:"
for_ pkgs $ \f -> $logWarn (fromString f) for_ pkgs $ \f -> $logWarn (fromString f)
@@ -460,25 +517,25 @@ upload (Upload name mpkg shouldIndex) = do
Just s -> pure s Just s -> pure s
noBody <- noBody <-
parseRequest ("POST " <> show publishCfgRepoLocation <> "/admin/v0/upload") parseRequest ("POST " <> show publishCfgRepoLocation <> "/admin/v0/upload")
<&> setRequestHeaders [("accept", "text/plain")] <&> setRequestHeaders [("accept", "text/plain")]
<&> applyBasicAuth (B8.pack publishCfgRepoUser) (B8.pack publishCfgRepoPass) <&> applyBasicAuth (B8.pack publishCfgRepoUser) (B8.pack publishCfgRepoPass)
size <- getFileSize pkg size <- getFileSize pkg
bar <- newProgressBar defStyle 30 (Progress 0 (fromIntegral size) ()) bar <- newProgressBar defStyle 30 (Progress 0 (fromIntegral size) ())
body <- observedStreamFile (updateProgress bar . const . sfs2prog) pkg body <- observedStreamFile (updateProgress bar . const . sfs2prog) pkg
let withBody = setRequestBody body noBody let withBody = setRequestBody body noBody
manager <- newTlsManager manager <- newTlsManager
res <- runReaderT (httpLbs withBody) manager res <- runReaderT (httpLbs withBody) manager
if getResponseStatus res == status200 if getResponseStatus res == status200
-- no output is successful then -- no output is successful
then pure () pure ()
else do else do
$logError (decodeUtf8 . LB.toStrict $ getResponseBody res) $logError (decodeUtf8 . LB.toStrict $ getResponseBody res)
exitWith $ ExitFailure 1 exitWith $ ExitFailure 1
putChunkLn $ fromString ("Successfully uploaded " <> pkg) & fore green putChunkLn $ fromString ("Successfully uploaded " <> pkg) & fore green
when shouldIndex $ do when shouldIndex $ do
home <- getHomeDirectory home <- getHomeDirectory
manifestBytes <- sourceManifest (home </> ".cargo/bin") pkg $ \c -> runConduit (c .| foldC) manifestBytes <- sourceManifest (home </> ".cargo/bin") pkg $ \c -> runConduit (c .| foldC)
PackageManifest { packageManifestId, packageManifestVersion } <- case eitherDecodeStrict manifestBytes of PackageManifest{packageManifestId, packageManifestVersion} <- case eitherDecodeStrict manifestBytes of
Left s -> do Left s -> do
$logError $ "Could not parse the manifest of the package: " <> toS s $logError $ "Could not parse the manifest of the package: " <> toS s
exitWith $ ExitFailure 1 exitWith $ ExitFailure 1
@@ -486,45 +543,53 @@ upload (Upload name mpkg shouldIndex) = do
let pkgId = toS $ unPkgId packageManifestId let pkgId = toS $ unPkgId packageManifestId
index name pkgId packageManifestVersion index name pkgId packageManifestVersion
putChunkLn $ fromString ("Successfully indexed " <> pkgId <> "@" <> show packageManifestVersion) & fore green putChunkLn $ fromString ("Successfully indexed " <> pkgId <> "@" <> show packageManifestVersion) & fore green
where where
sfs2prog :: StreamFileStatus -> Progress () sfs2prog :: StreamFileStatus -> Progress ()
sfs2prog StreamFileStatus {..} = Progress (fromIntegral readSoFar) (fromIntegral fileSize) () sfs2prog StreamFileStatus{..} = Progress (fromIntegral readSoFar) (fromIntegral fileSize) ()
index :: String -> String -> Version -> IO () index :: String -> String -> Version -> IO ()
index name pkg v = performHttp name "POST" [i|/admin/v0/index|] (IndexPkgReq (PkgId $ toS pkg) v) index name pkg v = performHttp name "POST" [i|/admin/v0/index|] (IndexPkgReq (PkgId $ toS pkg) v)
deindex :: String -> String -> Version -> IO () deindex :: String -> String -> Version -> IO ()
deindex name pkg v = performHttp name "POST" [i|/admin/v0/deindex|] (IndexPkgReq (PkgId $ toS pkg) v) deindex name pkg v = performHttp name "POST" [i|/admin/v0/deindex|] (IndexPkgReq (PkgId $ toS pkg) v)
listUnindexed :: String -> IO () listUnindexed :: String -> IO ()
listUnindexed name = do listUnindexed name = do
PublishCfgRepo {..} <- findNameInCfg name PublishCfgRepo{..} <- findNameInCfg name
noBody <- noBody <-
parseRequest (show publishCfgRepoLocation <> "/admin/v0/deindex") parseRequest (show publishCfgRepoLocation <> "/admin/v0/deindex")
<&> setRequestHeaders [("accept", "application/json")] <&> setRequestHeaders [("accept", "application/json")]
<&> applyBasicAuth (B8.pack publishCfgRepoUser) (B8.pack publishCfgRepoPass) <&> applyBasicAuth (B8.pack publishCfgRepoUser) (B8.pack publishCfgRepoPass)
PackageList {..} <- getResponseBody <$> httpJSON noBody PackageList{..} <- getResponseBody <$> httpJSON noBody
void $ flip traverseWithKey unPackageList $ \k v -> do void $
putChunk (chunk (unPkgId k <> ": ") & fore blue) flip traverseWithKey unPackageList $ \k v -> do
putChunkLn $ chunk (show v) & fore yellow putChunk (chunk (unPkgId k <> ": ") & fore blue)
putChunkLn $ chunk (show v) & fore yellow
catAdd :: String -> String -> Maybe String -> Maybe Int -> IO () catAdd :: String -> String -> Maybe String -> Maybe Int -> IO ()
catAdd target name desc pri = catAdd target name desc pri =
performHttp target "POST" [i|/admin/v0/category/#{name}|] (AddCategoryReq (toS <$> desc) pri) performHttp target "POST" [i|/admin/v0/category/#{name}|] (AddCategoryReq (toS <$> desc) pri)
catDel :: String -> String -> IO () catDel :: String -> String -> IO ()
catDel target name = performHttp target "DELETE" [i|/admin/v0/category/#{name}|] () catDel target name = performHttp target "DELETE" [i|/admin/v0/category/#{name}|] ()
pkgCatAdd :: String -> PkgId -> String -> IO () pkgCatAdd :: String -> PkgId -> String -> IO ()
pkgCatAdd target pkg cat = performHttp target "POST" [i|/admin/v0/categorize/#{cat}/#{pkg}|] () pkgCatAdd target pkg cat = performHttp target "POST" [i|/admin/v0/categorize/#{cat}/#{pkg}|] ()
pkgCatDel :: String -> PkgId -> String -> IO () pkgCatDel :: String -> PkgId -> String -> IO ()
pkgCatDel target pkg cat = performHttp target "DELETE" [i|/admin/v0/categorize/#{cat}/#{pkg}|] () pkgCatDel target pkg cat = performHttp target "DELETE" [i|/admin/v0/categorize/#{cat}/#{pkg}|] ()
findNameInCfg :: String -> IO PublishCfgRepo findNameInCfg :: String -> IO PublishCfgRepo
findNameInCfg name = do findNameInCfg name = do
loc <- cfgLocation loc <- cfgLocation
PublishCfg cfg <- inputFile Dhall.auto loc PublishCfg cfg <- inputFile Dhall.auto loc
case lookup name cfg of case lookup name cfg of
Nothing -> do Nothing -> do
@@ -532,13 +597,14 @@ findNameInCfg name = do
exitWith $ ExitFailure 1 exitWith $ ExitFailure 1
Just pcr -> pure pcr Just pcr -> pure pcr
performHttp :: ToJSON a => String -> String -> String -> a -> IO () performHttp :: ToJSON a => String -> String -> String -> a -> IO ()
performHttp target method route body = do performHttp target method route body = do
PublishCfgRepo {..} <- findNameInCfg target PublishCfgRepo{..} <- findNameInCfg target
noBody <- noBody <-
parseRequest (method <> " " <> show publishCfgRepoLocation <> route) parseRequest (method <> " " <> show publishCfgRepoLocation <> route)
<&> setRequestHeaders [("accept", "text/plain")] <&> setRequestHeaders [("accept", "text/plain")]
<&> applyBasicAuth (B8.pack publishCfgRepoUser) (B8.pack publishCfgRepoPass) <&> applyBasicAuth (B8.pack publishCfgRepoUser) (B8.pack publishCfgRepoPass)
let withBody = setRequestBodyJSON body noBody let withBody = setRequestBodyJSON body noBody
res <- httpLBS withBody res <- httpLBS withBody
if getResponseStatus res == status200 if getResponseStatus res == status200
@@ -549,12 +615,13 @@ performHttp target method route body = do
instance MonadLogger IO where instance MonadLogger IO where
monadLoggerLog _ _ LevelDebug = putChunkLn . colorLog white monadLoggerLog _ _ LevelDebug = putChunkLn . colorLog white
monadLoggerLog _ _ LevelInfo = putChunkLn . colorLog blue monadLoggerLog _ _ LevelInfo = putChunkLn . colorLog blue
monadLoggerLog _ _ LevelWarn = putChunkLn . colorLog yellow monadLoggerLog _ _ LevelWarn = putChunkLn . colorLog yellow
monadLoggerLog _ _ LevelError = putChunkLn . colorLog red monadLoggerLog _ _ LevelError = putChunkLn . colorLog red
monadLoggerLog _ _ (LevelOther _) = putChunkLn . colorLog magenta monadLoggerLog _ _ (LevelOther _) = putChunkLn . colorLog magenta
colorLog :: ToLogStr msg => Radiant -> msg -> Chunk colorLog :: ToLogStr msg => Radiant -> msg -> Chunk
colorLog c m = fore c $ chunk . decodeUtf8 . fromLogStr . toLogStr $ m colorLog c m = fore c $ chunk . decodeUtf8 . fromLogStr . toLogStr $ m
instance MonadLoggerIO IO where instance MonadLoggerIO IO where

225
src/Database/Marketplace.hs
View File

@@ -1,225 +0,0 @@
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Fuse on/on" #-}
module Database.Marketplace where
import Conduit ( ConduitT
, MonadResource
, MonadUnliftIO
, awaitForever
, leftover
, yield
)
import Control.Monad.Loops ( unfoldM )
import Data.Conduit ( await )
import Database.Esqueleto.Experimental
( (%)
, (&&.)
, (++.)
, (:&)(..)
, (==.)
, (^.)
, asc
, desc
, from
, groupBy
, ilike
, in_
, innerJoin
, on
, orderBy
, select
, selectSource
, table
, val
, valList
, where_
, (||.)
)
import qualified Database.Persist as P
import Database.Persist.Postgresql ( ConnectionPool
, Entity(entityKey, entityVal)
, PersistEntity(Key)
, SqlBackend
, runSqlPool
)
import Handler.Types.Marketplace ( PackageDependencyMetadata(..) )
import Lib.Types.AppIndex ( PkgId )
import Lib.Types.Emver ( Version )
import Model ( Category
, EntityField
( CategoryId
, CategoryName
, PkgCategoryCategoryId
, PkgCategoryPkgId
, PkgDependencyDepId
, PkgDependencyPkgId
, PkgDependencyPkgVersion
, PkgRecordId
, VersionRecordDescLong
, VersionRecordDescShort
, VersionRecordNumber
, VersionRecordPkgId
, VersionRecordTitle
, VersionRecordUpdatedAt
)
, Key(PkgRecordKey, unPkgRecordKey)
, PkgCategory
, PkgDependency
, PkgRecord
, VersionRecord(versionRecordNumber, versionRecordPkgId)
)
import Startlude ( ($)
, ($>)
, (.)
, (<$>)
, Applicative(pure)
, Down(Down)
, Eq((==))
, Functor(fmap)
, Maybe(..)
, Monad
, MonadIO
, ReaderT
, Text
, headMay
, lift
, snd
, sortOn
)
type CategoryTitle = Text
searchServices :: (MonadResource m, MonadIO m)
=> Maybe CategoryTitle
-> Text
-> ConduitT () (Entity VersionRecord) (ReaderT SqlBackend m) ()
searchServices Nothing query = selectSource $ do
service <- from $ table @VersionRecord
where_
( (service ^. VersionRecordDescShort `ilike` (%) ++. val query ++. (%))
||. (service ^. VersionRecordDescLong `ilike` (%) ++. val query ++. (%))
||. (service ^. VersionRecordTitle `ilike` (%) ++. val query ++. (%))
)
groupBy (service ^. VersionRecordPkgId, service ^. VersionRecordNumber)
orderBy
[ asc (service ^. VersionRecordPkgId)
, desc (service ^. VersionRecordNumber)
, desc (service ^. VersionRecordUpdatedAt)
]
pure service
searchServices (Just category) query = selectSource $ do
services <- from
(do
(service :& _ :& cat) <-
from
$ table @VersionRecord
`innerJoin` table @PkgCategory
`on` (\(s :& sc) -> sc ^. PkgCategoryPkgId ==. s ^. VersionRecordPkgId)
`innerJoin` table @Category
`on` (\(_ :& sc :& cat) -> sc ^. PkgCategoryCategoryId ==. cat ^. CategoryId)
-- if there is a cateogry, only search in category
-- weight title, short, long (bitcoin should equal Bitcoin Core)
where_
$ cat
^. CategoryName
==. val category
&&. ( (service ^. VersionRecordDescShort `ilike` (%) ++. val query ++. (%))
||. (service ^. VersionRecordDescLong `ilike` (%) ++. val query ++. (%))
||. (service ^. VersionRecordTitle `ilike` (%) ++. val query ++. (%))
)
pure service
)
groupBy (services ^. VersionRecordPkgId, services ^. VersionRecordNumber)
orderBy
[ asc (services ^. VersionRecordPkgId)
, desc (services ^. VersionRecordNumber)
, desc (services ^. VersionRecordUpdatedAt)
]
pure services
getPkgData :: (MonadResource m, MonadIO m) => [PkgId] -> ConduitT () (Entity VersionRecord) (ReaderT SqlBackend m) ()
getPkgData pkgs = selectSource $ do
pkgData <- from $ table @VersionRecord
where_ (pkgData ^. VersionRecordPkgId `in_` valList (PkgRecordKey <$> pkgs))
pure pkgData
getPkgDependencyData :: MonadIO m
=> Key PkgRecord
-> Version
-> ReaderT SqlBackend m [(Entity PkgDependency, Entity PkgRecord)]
getPkgDependencyData pkgId pkgVersion = select $ do
from
(do
(pkgDepRecord :& depPkgRecord) <-
from
$ table @PkgDependency
`innerJoin` table @PkgRecord
`on` (\(pdr :& dpr) -> dpr ^. PkgRecordId ==. pdr ^. PkgDependencyDepId)
where_ (pkgDepRecord ^. PkgDependencyPkgId ==. val pkgId)
where_ (pkgDepRecord ^. PkgDependencyPkgVersion ==. val pkgVersion)
pure (pkgDepRecord, depPkgRecord)
)
zipCategories :: MonadUnliftIO m
=> ConduitT
(PkgId, [Entity VersionRecord])
(PkgId, [Entity VersionRecord], [Entity Category])
(ReaderT SqlBackend m)
()
zipCategories = awaitForever $ \(pkg, vers) -> do
raw <- lift $ select $ do
(sc :& cat) <-
from
$ table @PkgCategory
`innerJoin` table @Category
`on` (\(sc :& cat) -> sc ^. PkgCategoryCategoryId ==. cat ^. CategoryId)
where_ (sc ^. PkgCategoryPkgId ==. val (PkgRecordKey pkg))
pure cat
yield (pkg, vers, raw)
collateVersions :: MonadUnliftIO m
=> ConduitT (Entity VersionRecord) (PkgId, [Entity VersionRecord]) (ReaderT SqlBackend m) ()
collateVersions = awaitForever $ \v0 -> do
let pkg = unPkgRecordKey . versionRecordPkgId $ entityVal v0
let pull = do
mvn <- await
case mvn of
Nothing -> pure Nothing
Just vn -> do
let pkg' = unPkgRecordKey . versionRecordPkgId $ entityVal vn
if pkg == pkg' then pure (Just vn) else leftover vn $> Nothing
ls <- unfoldM pull
yield (pkg, v0 : ls)
zipDependencyVersions :: (Monad m, MonadIO m)
=> (Entity PkgDependency, Entity PkgRecord)
-> ReaderT SqlBackend m PackageDependencyMetadata
zipDependencyVersions (pkgDepRecord, depRecord) = do
let pkgDbId = entityKey depRecord
depVers <- select $ do
v <- from $ table @VersionRecord
where_ $ v ^. VersionRecordPkgId ==. val pkgDbId
pure v
pure $ PackageDependencyMetadata { packageDependencyMetadataPkgDependencyRecord = pkgDepRecord
, packageDependencyMetadataDepPkgRecord = depRecord
, packageDependencyMetadataDepVersions = depVers
}
fetchAllAppVersions :: MonadUnliftIO m => ConnectionPool -> PkgId -> m [VersionRecord]
fetchAllAppVersions appConnPool appId = do
entityAppVersions <- runSqlPool (P.selectList [VersionRecordPkgId P.==. PkgRecordKey appId] []) appConnPool
pure $ entityVal <$> entityAppVersions
fetchLatestApp :: MonadIO m => PkgId -> ReaderT SqlBackend m (Maybe (P.Entity PkgRecord, P.Entity VersionRecord))
fetchLatestApp appId = fmap headMay . sortResults . select $ do
(service :& version) <-
from
$ table @PkgRecord
`innerJoin` table @VersionRecord
`on` (\(service :& version) -> service ^. PkgRecordId ==. version ^. VersionRecordPkgId)
where_ (service ^. PkgRecordId ==. val (PkgRecordKey appId))
pure (service, version)
where sortResults = fmap $ sortOn (Down . versionRecordNumber . entityVal . snd)

303
src/Database/Queries.hs
View File

@@ -1,65 +1,280 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
module Database.Queries where module Database.Queries where
import Database.Persist.Sql ( PersistStoreRead(get) import Database.Persist.Sql (
, PersistStoreWrite(insertKey, insert_, repsert) PersistStoreRead (get),
, SqlBackend PersistStoreWrite (insertKey, insert_, repsert),
) SqlBackend,
import Lib.Types.AppIndex ( PackageManifest(..) )
, PkgId import Lib.Types.Core (
) PkgId,
import Lib.Types.Emver ( Version ) )
import Model ( Key(PkgRecordKey, VersionRecordKey) import Lib.Types.Emver (Version)
, Metric(Metric) import Model (
, PkgRecord(PkgRecord) Key (PkgRecordKey, VersionRecordKey),
, VersionRecord(VersionRecord) Metric (Metric),
) PkgDependency (..),
import Orphans.Emver ( ) PkgRecord (PkgRecord),
import Startlude ( ($) VersionRecord (VersionRecord),
, (.) )
, ConvertText(toS) import Orphans.Emver ()
, Maybe(..) import Startlude (
, MonadIO(..) ConvertText (toS),
, ReaderT Maybe (..),
, SomeException MonadIO (..),
, getCurrentTime ReaderT,
, maybe SomeException,
) getCurrentTime,
import System.FilePath ( takeExtension ) maybe,
import UnliftIO ( MonadUnliftIO ($),
, try (.),
) )
import System.FilePath (takeExtension)
import UnliftIO (
MonadUnliftIO,
try,
)
import Conduit (
ConduitT,
MonadResource,
awaitForever,
leftover,
yield,
)
import Control.Monad.Loops (unfoldM)
import Data.Conduit (await)
import Database.Esqueleto.Experimental (
PersistEntity,
SqlExpr,
Value,
asc,
desc,
from,
groupBy,
ilike,
in_,
innerJoin,
on,
orderBy,
select,
selectSource,
table,
val,
valList,
where_,
(%),
(&&.),
(++.),
(:&) (..),
(==.),
(^.),
(||.),
)
import Database.Persist qualified as P
import Database.Persist.Postgresql (
ConnectionPool,
Entity (entityVal),
runSqlPool,
)
import Lib.Types.Manifest (PackageManifest (..))
import Model (
Category,
EntityField (
CategoryId,
CategoryName,
PkgCategoryCategoryId,
PkgCategoryPkgId,
PkgDependencyPkgId,
PkgDependencyPkgVersion,
PkgRecordId,
VersionRecordDescLong,
VersionRecordDescShort,
VersionRecordNumber,
VersionRecordPkgId,
VersionRecordTitle,
VersionRecordUpdatedAt
),
Key (unPkgRecordKey),
PkgCategory,
VersionRecord (versionRecordNumber, versionRecordPkgId),
)
import Startlude (
Applicative (pure),
Bool,
Down (Down),
Eq ((==)),
Functor (fmap),
Monad,
Text,
headMay,
snd,
sortOn,
($>),
(<$>),
)
serviceQuerySource ::
(MonadResource m, MonadIO m) =>
Maybe Text ->
Text ->
ConduitT () (Entity VersionRecord) (ReaderT SqlBackend m) ()
serviceQuerySource mCat query = selectSource $ do
service <- case mCat of
Nothing -> do
service <- from $ table @VersionRecord
where_ $ queryInMetadata query service
pure service
Just category -> do
(service :& _ :& cat) <-
from $
table @VersionRecord
`innerJoin` table @PkgCategory `on` (VersionRecordPkgId === PkgCategoryPkgId)
`innerJoin` table @Category `on` (\(_ :& a :& b) -> (PkgCategoryCategoryId === CategoryId) (a :& b))
-- if there is a cateogry, only search in category
-- weight title, short, long (bitcoin should equal Bitcoin Core)
where_ $ cat ^. CategoryName ==. val category &&. queryInMetadata query service
pure service
groupBy (service ^. VersionRecordPkgId, service ^. VersionRecordNumber)
orderBy
[ asc (service ^. VersionRecordPkgId)
, desc (service ^. VersionRecordNumber)
, desc (service ^. VersionRecordUpdatedAt)
]
pure service
queryInMetadata :: Text -> SqlExpr (Entity VersionRecord) -> (SqlExpr (Value Bool))
queryInMetadata query service =
(service ^. VersionRecordDescShort `ilike` (%) ++. val query ++. (%))
||. (service ^. VersionRecordDescLong `ilike` (%) ++. val query ++. (%))
||. (service ^. VersionRecordTitle `ilike` (%) ++. val query ++. (%))
getPkgDataSource :: (MonadResource m, MonadIO m) => [PkgId] -> ConduitT () (Entity VersionRecord) (ReaderT SqlBackend m) ()
getPkgDataSource pkgs = selectSource $ do
pkgData <- from $ table @VersionRecord
where_ (pkgData ^. VersionRecordPkgId `in_` valList (PkgRecordKey <$> pkgs))
pure pkgData
getPkgDependencyData ::
MonadIO m =>
PkgId ->
Version ->
ReaderT SqlBackend m [PkgDependency]
getPkgDependencyData pkgId pkgVersion = fmap (fmap entityVal) $
select $
from $ do
pkgDepRecord <- from $ table @PkgDependency
where_ (pkgDepRecord ^. PkgDependencyPkgId ==. val (PkgRecordKey pkgId))
where_ (pkgDepRecord ^. PkgDependencyPkgVersion ==. val pkgVersion)
pure pkgDepRecord
(===) ::
(PersistEntity val1, PersistEntity val2, P.PersistField typ) =>
EntityField val1 typ ->
EntityField val2 typ ->
(SqlExpr (Entity val1) :& SqlExpr (Entity val2)) ->
SqlExpr (Value Bool)
(===) a' b' (a :& b) = a ^. a' ==. b ^. b'
getCategoriesFor ::
MonadUnliftIO m =>
PkgId ->
ReaderT SqlBackend m [Category]
getCategoriesFor pkg = fmap (fmap entityVal) $
select $ do
(sc :& cat) <-
from $
table @PkgCategory
`innerJoin` table @Category `on` (PkgCategoryCategoryId === CategoryId)
where_ (sc ^. PkgCategoryPkgId ==. val (PkgRecordKey pkg))
pure cat
collateVersions ::
MonadUnliftIO m =>
ConduitT (Entity VersionRecord) (PkgId, [VersionRecord]) (ReaderT SqlBackend m) ()
collateVersions = awaitForever $ \v0 -> do
let pkg = unPkgRecordKey . versionRecordPkgId $ entityVal v0
let pull = do
mvn <- await
case mvn of
Nothing -> pure Nothing
Just vn -> do
let pkg' = unPkgRecordKey . versionRecordPkgId $ entityVal vn
if pkg == pkg' then pure (Just vn) else leftover vn $> Nothing
ls <- unfoldM pull
yield (pkg, fmap entityVal $ v0 : ls)
getDependencyVersions ::
(Monad m, MonadIO m) =>
PkgDependency ->
ReaderT SqlBackend m [VersionRecord]
getDependencyVersions pkgDepRecord = do
let pkgDbId = pkgDependencyDepId pkgDepRecord
depVers <- select $ do
v <- from $ table @VersionRecord
where_ $ v ^. VersionRecordPkgId ==. val pkgDbId
pure v
pure $ entityVal <$> depVers
fetchAllAppVersions :: MonadUnliftIO m => ConnectionPool -> PkgId -> m [VersionRecord]
fetchAllAppVersions appConnPool appId = do
entityAppVersions <- runSqlPool (P.selectList [VersionRecordPkgId P.==. PkgRecordKey appId] []) appConnPool
pure $ entityVal <$> entityAppVersions
fetchApp :: MonadIO m => PkgId -> ReaderT SqlBackend m (Maybe PkgRecord)
fetchApp = get . PkgRecordKey
fetchAppVersion :: MonadIO m => PkgId -> Version -> ReaderT SqlBackend m (Maybe VersionRecord) fetchAppVersion :: MonadIO m => PkgId -> Version -> ReaderT SqlBackend m (Maybe VersionRecord)
fetchAppVersion pkgId version = get (VersionRecordKey (PkgRecordKey pkgId) version) fetchAppVersion pkgId version = get (VersionRecordKey (PkgRecordKey pkgId) version)
fetchLatestApp :: MonadIO m => PkgId -> ReaderT SqlBackend m (Maybe (P.Entity PkgRecord, P.Entity VersionRecord))
fetchLatestApp appId = fmap headMay . sortResults . select $ do
(service :& version) <-
from $
table @PkgRecord
`innerJoin` table @VersionRecord
`on` (\(service :& version) -> service ^. PkgRecordId ==. version ^. VersionRecordPkgId)
where_ (service ^. PkgRecordId ==. val (PkgRecordKey appId))
pure (service, version)
where
sortResults = fmap $ sortOn (Down . versionRecordNumber . entityVal . snd)
createMetric :: MonadIO m => PkgId -> Version -> ReaderT SqlBackend m () createMetric :: MonadIO m => PkgId -> Version -> ReaderT SqlBackend m ()
createMetric appId version = do createMetric appId version = do
time <- liftIO getCurrentTime time <- liftIO getCurrentTime
insert_ $ Metric time (PkgRecordKey appId) version insert_ $ Metric time (PkgRecordKey appId) version
upsertPackageVersion :: (MonadUnliftIO m) => PackageManifest -> ReaderT SqlBackend m () upsertPackageVersion :: (MonadUnliftIO m) => PackageManifest -> ReaderT SqlBackend m ()
upsertPackageVersion PackageManifest {..} = do upsertPackageVersion PackageManifest{..} = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
let iconType = maybe "png" (toS . takeExtension . toS) packageManifestIcon let iconType = maybe "png" (toS . takeExtension . toS) packageManifestIcon
let pkgId = PkgRecordKey packageManifestId let pkgId = PkgRecordKey packageManifestId
let ins = VersionRecord now let ins =
(Just now) VersionRecord
pkgId now
packageManifestVersion (Just now)
packageManifestTitle pkgId
packageManifestDescriptionShort packageManifestVersion
packageManifestDescriptionLong packageManifestTitle
iconType packageManifestDescriptionShort
packageManifestReleaseNotes packageManifestDescriptionLong
packageManifestEosVersion iconType
Nothing packageManifestReleaseNotes
packageManifestEosVersion
Nothing
_res <- try @_ @SomeException $ insertKey pkgId (PkgRecord now (Just now)) _res <- try @_ @SomeException $ insertKey pkgId (PkgRecord now (Just now))
repsert (VersionRecordKey pkgId packageManifestVersion) ins repsert (VersionRecordKey pkgId packageManifestVersion) ins

394
src/Foundation.hs
View File

@@ -1,184 +1,202 @@
{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE BangPatterns #-} {-# LANGUAGE BangPatterns #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Foundation where module Foundation where
import Startlude ( ($) import Startlude (
, (.) Applicative (pure),
, (<$>) Bool (False),
, (<&>) Eq ((==)),
, (<**>) IO,
, (=<<) MVar,
, Applicative(pure) Maybe (..),
, Bool(False) Monad (return),
, Eq((==)) Monoid (mempty),
, IO Semigroup ((<>)),
, MVar String,
, Maybe(..) Text,
, Monad(return) ThreadId,
, Monoid(mempty) Word64,
, Semigroup((<>)) decodeUtf8,
, String drop,
, Text encodeUtf8,
, ThreadId flip,
, Word64 fst,
, decodeUtf8 isJust,
, drop otherwise,
, encodeUtf8 putMVar,
, flip show,
, fst when,
, isJust ($),
, otherwise (.),
, putMVar (<$>),
, show (<&>),
, when (<**>),
, (||) (=<<),
) (||),
)
import Control.Monad.Logger ( Loc import Control.Monad.Logger (
, LogSource Loc,
, LogStr LogSource,
, ToLogStr(toLogStr) LogStr,
, fromLogStr ToLogStr (toLogStr),
) fromLogStr,
import Database.Persist.Sql ( ConnectionPool )
, LogFunc import Database.Persist.Sql (
, PersistStoreRead(get) ConnectionPool,
, SqlBackend LogFunc,
, SqlPersistT PersistStoreRead (get),
, runSqlPool SqlBackend,
) SqlPersistT,
import Lib.Registry ( S9PK ) runSqlPool,
import Yesod.Core ( AuthResult(Authorized, Unauthorized) )
, LogLevel(..) import Yesod.Core (
, MonadHandler(liftHandler) AuthResult (Authorized, Unauthorized),
, RenderMessage(..) LogLevel (..),
, RenderRoute(Route, renderRoute) MonadHandler (liftHandler),
, RouteAttrs(routeAttrs) RenderMessage (..),
, SessionBackend RenderRoute (Route, renderRoute),
, ToTypedContent RouteAttrs (routeAttrs),
, Yesod SessionBackend,
( isAuthorized ToTypedContent,
, makeLogger Yesod (
, makeSessionBackend isAuthorized,
, maximumContentLengthIO makeLogger,
, messageLoggerSource makeSessionBackend,
, shouldLogIO maximumContentLengthIO,
, yesodMiddleware messageLoggerSource,
) shouldLogIO,
, defaultYesodMiddleware yesodMiddleware
, getYesod ),
, getsYesod defaultYesodMiddleware,
, mkYesodData getYesod,
, parseRoutesFile getsYesod,
) mkYesodData,
import Yesod.Core.Types ( HandlerData(handlerEnv) parseRoutesFile,
, Logger(loggerDate) )
, RunHandlerEnv(rheChild, rheSite) import Yesod.Core.Types (
, loggerPutStr HandlerData (handlerEnv),
) Logger (loggerDate),
import qualified Yesod.Core.Unsafe as Unsafe RunHandlerEnv (rheChild, rheSite),
loggerPutStr,
)
import Yesod.Core.Unsafe qualified as Unsafe
import Control.Monad.Logger.Extras (wrapSGRCode)
import Control.Monad.Reader.Has (Has (extract, update))
import Crypto.Hash (
SHA256 (SHA256),
hashWith,
)
import Data.Set (member)
import Data.String.Interpolate.IsString (
i,
)
import Data.Text qualified as T
import Handler.Types.Api (ApiVersion (..))
import Language.Haskell.TH (Loc (..))
import Lib.PkgRepository (
EosRepo,
PkgRepo,
)
import Lib.Types.Core (PkgId, S9PK)
import Model (
Admin (..),
Key (AdminKey),
)
import Settings (AppSettings (appShouldLogAll))
import System.Console.ANSI.Codes (
Color (..),
ColorIntensity (..),
ConsoleLayer (Foreground),
SGR (SetColor),
)
import Yesod (
FormMessage,
defaultFormMessage,
)
import Yesod.Auth (
AuthEntity,
Creds (credsIdent),
YesodAuth (
AuthId,
authPlugins,
getAuthId,
loginDest,
logoutDest,
maybeAuthId
),
YesodAuthPersist (getAuthEntity),
)
import Yesod.Auth.Http.Basic (
defaultAuthSettings,
defaultMaybeBasicAuthId,
)
import Yesod.Persist.Core (
DBRunner,
YesodPersist (..),
YesodPersistRunner (..),
defaultGetDBRunner,
)
import Control.Monad.Logger.Extras ( wrapSGRCode )
import Control.Monad.Reader.Has ( Has(extract, update) )
import Crypto.Hash ( SHA256(SHA256)
, hashWith
)
import Data.Set ( member )
import Data.String.Interpolate.IsString
( i )
import qualified Data.Text as T
import Language.Haskell.TH ( Loc(..) )
import Lib.PkgRepository ( EosRepo
, PkgRepo
)
import Lib.Types.AppIndex ( PkgId )
import Model ( Admin(..)
, Key(AdminKey)
)
import Settings ( AppSettings(appShouldLogAll) )
import System.Console.ANSI.Codes ( Color(..)
, ColorIntensity(..)
, ConsoleLayer(Foreground)
, SGR(SetColor)
)
import Yesod ( FormMessage
, defaultFormMessage
)
import Yesod.Auth ( AuthEntity
, Creds(credsIdent)
, YesodAuth
( AuthId
, authPlugins
, getAuthId
, loginDest
, logoutDest
, maybeAuthId
)
, YesodAuthPersist(getAuthEntity)
)
import Yesod.Auth.Http.Basic ( defaultAuthSettings
, defaultMaybeBasicAuthId
)
import Yesod.Persist.Core ( DBRunner
, YesodPersist(..)
, YesodPersistRunner(..)
, defaultGetDBRunner
)
-- | The foundation datatype for your application. This can be a good place to -- | The foundation datatype for your application. This can be a good place to
-- keep settings and values requiring initialization before your application -- keep settings and values requiring initialization before your application
-- starts running, such as database connections. Every handler will have -- starts running, such as database connections. Every handler will have
-- access to the data present here. -- access to the data present here.
data RegistryCtx = RegistryCtx data RegistryCtx = RegistryCtx
{ appSettings :: AppSettings { appSettings :: AppSettings
, appLogger :: Logger , appLogger :: Logger
, appWebServerThreadId :: MVar (ThreadId, ThreadId) , appWebServerThreadId :: MVar (ThreadId, ThreadId)
, appShouldRestartWeb :: MVar Bool , appShouldRestartWeb :: MVar Bool
, appConnPool :: ConnectionPool , appConnPool :: ConnectionPool
, appStopFsNotifyEos :: IO Bool , appStopFsNotifyEos :: IO Bool
} }
instance Has PkgRepo RegistryCtx where instance Has PkgRepo RegistryCtx where
extract = transitiveExtract @AppSettings extract = transitiveExtract @AppSettings
update = transitiveUpdate @AppSettings update = transitiveUpdate @AppSettings
instance Has a r => Has a (HandlerData r r) where instance Has a r => Has a (HandlerData r r) where
extract = extract . rheSite . handlerEnv extract = extract . rheSite . handlerEnv
update f r = update f r =
let ctx = update f (rheSite $ handlerEnv r) let ctx = update f (rheSite $ handlerEnv r)
rhe = (handlerEnv r) { rheSite = ctx, rheChild = ctx } rhe = (handlerEnv r){rheSite = ctx, rheChild = ctx}
in r { handlerEnv = rhe } in r{handlerEnv = rhe}
instance Has AppSettings RegistryCtx where instance Has AppSettings RegistryCtx where
extract = appSettings extract = appSettings
update f ctx = ctx { appSettings = f (appSettings ctx) } update f ctx = ctx{appSettings = f (appSettings ctx)}
instance Has EosRepo RegistryCtx where instance Has EosRepo RegistryCtx where
extract = transitiveExtract @AppSettings extract = transitiveExtract @AppSettings
update = transitiveUpdate @AppSettings update = transitiveUpdate @AppSettings
{-# INLINE transitiveExtract #-} {-# INLINE transitiveExtract #-}
transitiveExtract :: forall b a c . (Has a b, Has b c) => c -> a transitiveExtract :: forall b a c. (Has a b, Has b c) => c -> a
transitiveExtract = extract @a . extract @b transitiveExtract = extract @a . extract @b
{-# INLINE transitiveUpdate #-} {-# INLINE transitiveUpdate #-}
transitiveUpdate :: forall b a c . (Has a b, Has b c) => (a -> a) -> (c -> c) transitiveUpdate :: forall b a c. (Has a b, Has b c) => (a -> a) -> (c -> c)
transitiveUpdate f = update (update @a @b f) transitiveUpdate f = update (update @a @b f)
setWebProcessThreadId :: (ThreadId, ThreadId) -> RegistryCtx -> IO () setWebProcessThreadId :: (ThreadId, ThreadId) -> RegistryCtx -> IO ()
setWebProcessThreadId tid@(!_, !_) a = putMVar (appWebServerThreadId a) tid setWebProcessThreadId tid@(!_, !_) a = putMVar (appWebServerThreadId a) tid
-- This is where we define all of the routes in our application. For a full -- This is where we define all of the routes in our application. For a full
-- explanation of the syntax, please see: -- explanation of the syntax, please see:
-- http://www.yesodweb.com/book/routing-and-handlers -- http://www.yesodweb.com/book/routing-and-handlers
@@ -193,68 +211,73 @@ setWebProcessThreadId tid@(!_, !_) a = putMVar (appWebServerThreadId a) tid
-- type Handler = HandlerT RegistryCtx IO -- type Handler = HandlerT RegistryCtx IO
mkYesodData "RegistryCtx" $(parseRoutesFile "config/routes") mkYesodData "RegistryCtx" $(parseRoutesFile "config/routes")
-- Please see the documentation for the Yesod typeclass. There are a number -- Please see the documentation for the Yesod typeclass. There are a number
-- of settings which can be configured by overriding methods here. -- of settings which can be configured by overriding methods here.
instance Yesod RegistryCtx where instance Yesod RegistryCtx where
-- Store session data on the client in encrypted cookies,
-- Store session data on the client in encrypted cookies, -- default session idle timeout is 120 minutes
-- default session idle timeout is 120 minutes
makeSessionBackend :: RegistryCtx -> IO (Maybe SessionBackend) makeSessionBackend :: RegistryCtx -> IO (Maybe SessionBackend)
makeSessionBackend _ = pure Nothing makeSessionBackend _ = pure Nothing
-- Yesod Middleware allows you to run code before and after each handler function.
-- The defaultYesodMiddleware adds the response header "Vary: Accept, Accept-Language" and performs authorization checks. -- Yesod Middleware allows you to run code before and after each handler function.
-- Some users may also want to add the defaultCsrfMiddleware, which: -- The defaultYesodMiddleware adds the response header "Vary: Accept, Accept-Language" and performs authorization checks.
-- a) Sets a cookie with a CSRF token in it. -- Some users may also want to add the defaultCsrfMiddleware, which:
-- b) Validates that incoming write requests include that token in either a header or POST parameter. -- a) Sets a cookie with a CSRF token in it.
-- To add it, chain it together with the defaultMiddleware: yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware -- b) Validates that incoming write requests include that token in either a header or POST parameter.
-- For details, see the CSRF documentation in the Yesod.Core.Handler module of the yesod-core package. -- To add it, chain it together with the defaultMiddleware: yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware
-- For details, see the CSRF documentation in the Yesod.Core.Handler module of the yesod-core package.
yesodMiddleware :: ToTypedContent res => Handler res -> Handler res yesodMiddleware :: ToTypedContent res => Handler res -> Handler res
yesodMiddleware = defaultYesodMiddleware yesodMiddleware = defaultYesodMiddleware
-- What messages should be logged. The following includes all messages when
-- in development, and warnings and errors in production. -- What messages should be logged. The following includes all messages when
-- in development, and warnings and errors in production.
shouldLogIO :: RegistryCtx -> LogSource -> LogLevel -> IO Bool shouldLogIO :: RegistryCtx -> LogSource -> LogLevel -> IO Bool
shouldLogIO app _source level = shouldLogIO app _source level =
return $ appShouldLogAll (appSettings app) || level == LevelInfo || level == LevelWarn || level == LevelError return $ appShouldLogAll (appSettings app) || level == LevelInfo || level == LevelWarn || level == LevelError
makeLogger :: RegistryCtx -> IO Logger makeLogger :: RegistryCtx -> IO Logger
makeLogger = return . appLogger makeLogger = return . appLogger
messageLoggerSource :: RegistryCtx -> Logger -> Loc -> LogSource -> LogLevel -> LogStr -> IO () messageLoggerSource :: RegistryCtx -> Logger -> Loc -> LogSource -> LogLevel -> LogStr -> IO ()
messageLoggerSource ctx logger = \loc src lvl str -> do messageLoggerSource ctx logger = \loc src lvl str -> do
shouldLog <- shouldLogIO ctx src lvl shouldLog <- shouldLogIO ctx src lvl
when shouldLog $ do when shouldLog $ do
date <- loggerDate logger date <- loggerDate logger
let let formatted =
formatted =
toLogStr date toLogStr date
<> ( toLogStr <> ( toLogStr
. wrapSGRCode [SetColor Foreground Vivid (colorFor lvl)] . wrapSGRCode [SetColor Foreground Vivid (colorFor lvl)]
$ fromLogStr $ fromLogStr
( " [" ( " ["
<> renderLvl lvl <> renderLvl lvl
<> (if T.null src then mempty else "#" <> toLogStr src) <> (if T.null src then mempty else "#" <> toLogStr src)
<> "] " <> "] "
<> str <> str
) )
) )
<> toLogStr <> toLogStr
(wrapSGRCode [SetColor Foreground Dull White] ( wrapSGRCode
[i| @ #{loc_filename loc}:#{fst $ loc_start loc}\n|] [SetColor Foreground Dull White]
) [i| @ #{loc_filename loc}:#{fst $ loc_start loc}\n|]
)
loggerPutStr logger formatted loggerPutStr logger formatted
where where
renderLvl lvl = case lvl of renderLvl lvl = case lvl of
LevelOther t -> toLogStr t LevelOther t -> toLogStr t
_ -> toLogStr @String $ drop 5 $ show lvl _ -> toLogStr @String $ drop 5 $ show lvl
colorFor = \case colorFor = \case
LevelDebug -> Green LevelDebug -> Green
LevelInfo -> Blue LevelInfo -> Blue
LevelWarn -> Yellow LevelWarn -> Yellow
LevelError -> Red LevelError -> Red
LevelOther _ -> White LevelOther _ -> White
isAuthorized :: Route RegistryCtx -> Bool -> Handler AuthResult isAuthorized :: Route RegistryCtx -> Bool -> Handler AuthResult
isAuthorized route _ isAuthorized route _
| "admin" `member` routeAttrs route = do | "admin" `member` routeAttrs route = do
@@ -262,9 +285,11 @@ instance Yesod RegistryCtx where
pure $ if hasAuthId then Authorized else Unauthorized "This feature is for admins only" pure $ if hasAuthId then Authorized else Unauthorized "This feature is for admins only"
| otherwise = pure Authorized | otherwise = pure Authorized
maximumContentLengthIO :: RegistryCtx -> Maybe (Route RegistryCtx) -> IO (Maybe Word64) maximumContentLengthIO :: RegistryCtx -> Maybe (Route RegistryCtx) -> IO (Maybe Word64)
maximumContentLengthIO _ (Just PkgUploadR) = pure Nothing maximumContentLengthIO _ (Just PkgUploadR) = pure Nothing
maximumContentLengthIO _ _ = pure $ Just 2097152 -- the original default maximumContentLengthIO _ _ = pure $ Just 2097152 -- the original default
-- How to run database actions. -- How to run database actions.
instance YesodPersist RegistryCtx where instance YesodPersist RegistryCtx where
@@ -272,37 +297,40 @@ instance YesodPersist RegistryCtx where
runDB :: SqlPersistT Handler a -> Handler a runDB :: SqlPersistT Handler a -> Handler a
runDB action = runSqlPool action . appConnPool =<< getYesod runDB action = runSqlPool action . appConnPool =<< getYesod
instance YesodPersistRunner RegistryCtx where instance YesodPersistRunner RegistryCtx where
getDBRunner :: Handler (DBRunner RegistryCtx, Handler ()) getDBRunner :: Handler (DBRunner RegistryCtx, Handler ())
getDBRunner = defaultGetDBRunner appConnPool getDBRunner = defaultGetDBRunner appConnPool
instance RenderMessage RegistryCtx FormMessage where instance RenderMessage RegistryCtx FormMessage where
renderMessage _ _ = defaultFormMessage renderMessage _ _ = defaultFormMessage
instance YesodAuth RegistryCtx where instance YesodAuth RegistryCtx where
type AuthId RegistryCtx = Text type AuthId RegistryCtx = Text
getAuthId = pure . Just . credsIdent getAuthId = pure . Just . credsIdent
maybeAuthId = do maybeAuthId = do
pool <- getsYesod appConnPool pool <- getsYesod appConnPool
let checkCreds k s = flip runSqlPool pool $ do let checkCreds k s = flip runSqlPool pool $ do
let passHash = hashWith SHA256 . encodeUtf8 . ("start9_admin:" <>) $ decodeUtf8 s let passHash = hashWith SHA256 . encodeUtf8 . ("start9_admin:" <>) $ decodeUtf8 s
get (AdminKey $ decodeUtf8 k) <&> \case get (AdminKey $ decodeUtf8 k) <&> \case
Nothing -> False Nothing -> False
Just Admin { adminPassHash } -> adminPassHash == passHash Just Admin{adminPassHash} -> adminPassHash == passHash
defaultMaybeBasicAuthId checkCreds defaultAuthSettings defaultMaybeBasicAuthId checkCreds defaultAuthSettings
loginDest _ = PackageListR loginDest _ = PackageIndexR V1
logoutDest _ = PackageListR logoutDest _ = PackageIndexR V1
authPlugins _ = [] authPlugins _ = []
instance YesodAuthPersist RegistryCtx where instance YesodAuthPersist RegistryCtx where
type AuthEntity RegistryCtx = Admin type AuthEntity RegistryCtx = Admin
getAuthEntity = liftHandler . runDB . get . AdminKey getAuthEntity = liftHandler . runDB . get . AdminKey
unsafeHandler :: RegistryCtx -> Handler a -> IO a unsafeHandler :: RegistryCtx -> Handler a -> IO a
unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger
-- Note: Some functionality previously present in the scaffolding has been -- Note: Some functionality previously present in the scaffolding has been
-- moved to documentation in the Wiki. Following are some hopefully helpful -- moved to documentation in the Wiki. Following are some hopefully helpful
-- links: -- links:

345
src/Handler/Admin.hs
View File

@@ -1,128 +1,148 @@
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
module Handler.Admin where module Handler.Admin where
import Conduit ( (.|) import Conduit (
, runConduit runConduit,
, sinkFile sinkFile,
) (.|),
import Control.Exception ( ErrorCall(ErrorCall) ) )
import Control.Monad.Reader.Has ( ask ) import Control.Exception (ErrorCall (ErrorCall))
import Control.Monad.Trans.Maybe ( MaybeT(..) ) import Control.Monad.Reader.Has (ask)
import Data.Aeson ( (.:) import Control.Monad.Trans.Maybe (MaybeT (..))
, (.:?) import Data.Aeson (
, (.=) FromJSON (parseJSON),
, FromJSON(parseJSON) ToJSON,
, ToJSON decodeFileStrict,
, decodeFileStrict object,
, object withObject,
, withObject (.:),
) (.:?),
import Data.HashMap.Internal.Strict ( HashMap (.=),
, differenceWith )
, filter import Data.HashMap.Internal.Strict (
, fromListWith HashMap,
) differenceWith,
import Data.List ( (\\) filter,
, null fromListWith,
) )
import Data.String.Interpolate.IsString import Data.List (
( i ) null,
import Database.Persist ( Entity(entityKey) (\\),
, PersistStoreRead(get) )
, PersistUniqueRead(getBy) import Data.String.Interpolate.IsString (
, PersistUniqueWrite(deleteBy, insertUnique, upsert) i,
, entityVal )
, insert_ import Database.Persist (
, selectList Entity (entityKey),
) PersistStoreRead (get),
import Database.Persist.Postgresql ( runSqlPoolNoTransaction ) PersistUniqueRead (getBy),
import Database.Queries ( upsertPackageVersion ) PersistUniqueWrite (deleteBy, insertUnique, upsert),
import Foundation ( Handler entityVal,
, RegistryCtx(..) insert_,
) selectList,
import Lib.PkgRepository ( PkgRepo(PkgRepo, pkgRepoFileRoot) )
, extractPkg import Database.Persist.Postgresql (runSqlPoolNoTransaction)
, getManifestLocation import Database.Queries (upsertPackageVersion)
, getPackages import Foundation (
, getVersionsFor Handler,
) RegistryCtx (..),
import Lib.Types.AppIndex ( PackageManifest(..) )
, PkgId(unPkgId) import Handler.Util (
) orThrow,
import Lib.Types.Emver ( Version(..) ) sendResponseText,
import Model ( Category(..) )
, Key(AdminKey, PkgRecordKey, VersionRecordKey) import Lib.PkgRepository (
, PkgCategory(PkgCategory) PkgRepo (PkgRepo, pkgRepoFileRoot),
, Unique(UniqueName, UniquePkgCategory) extractPkg,
, Upload(..) getManifestLocation,
, VersionRecord(versionRecordNumber, versionRecordPkgId) getPackages,
, unPkgRecordKey getVersionsFor,
) )
import Network.HTTP.Types ( status403 import Lib.Types.Core (
, status404 PkgId (unPkgId),
, status500 )
) import Lib.Types.Emver (Version (..))
import Settings import Lib.Types.Manifest (PackageManifest (..))
import Startlude ( ($) import Model (
, (&&&) Category (..),
, (.) Key (AdminKey, PkgRecordKey, VersionRecordKey),
, (<$>) PkgCategory (PkgCategory),
, (<<$>>) Unique (UniqueName, UniquePkgCategory),
, (<>) Upload (..),
, Applicative(pure) VersionRecord (versionRecordNumber, versionRecordPkgId),
, Bool(..) unPkgRecordKey,
, Eq )
, Int import Network.HTTP.Types (
, Maybe(..) status403,
, Monad((>>=)) status404,
, Show status500,
, SomeException(..) )
, Text import Settings
, asum import Startlude (
, fmap Applicative (pure),
, fromMaybe Bool (..),
, getCurrentTime Eq,
, guarded Int,
, hush Maybe (..),
, isNothing Monad ((>>=)),
, liftIO Show,
, not SomeException (..),
, replicate Text,
, show asum,
, throwIO fmap,
, toS fromMaybe,
, traverse getCurrentTime,
, void guarded,
, when hush,
, zip isNothing,
) liftIO,
import System.FilePath ( (<.>) not,
, (</>) replicate,
) show,
import UnliftIO ( try throwIO,
, withTempDirectory toS,
) traverse,
import UnliftIO.Directory ( createDirectoryIfMissing void,
, removePathForcibly when,
, renameDirectory zip,
, renameFile ($),
) (&&&),
import Util.Shared ( orThrow (.),
, sendResponseText (.*),
) (<$>),
import Yesod ( ToJSON(..) (<<$>>),
, delete (<>),
, getsYesod )
, logError import System.FilePath (
, rawRequestBody (<.>),
, requireCheckJsonBody (</>),
, runDB )
) import UnliftIO (
import Yesod.Auth ( YesodAuth(maybeAuthId) ) try,
import Yesod.Core.Types ( JSONResponse(JSONResponse) ) withTempDirectory,
)
import UnliftIO.Directory (
createDirectoryIfMissing,
removePathForcibly,
renameDirectory,
renameFile,
)
import Yesod (
ToJSON (..),
delete,
getsYesod,
logError,
rawRequestBody,
requireCheckJsonBody,
runDB,
)
import Yesod.Auth (YesodAuth (maybeAuthId))
import Yesod.Core.Types (JSONResponse (JSONResponse))
postPkgUploadR :: Handler () postPkgUploadR :: Handler ()
postPkgUploadR = do postPkgUploadR = do
@@ -131,14 +151,15 @@ postPkgUploadR = do
withTempDirectory resourcesTemp "newpkg" $ \dir -> do withTempDirectory resourcesTemp "newpkg" $ \dir -> do
let path = dir </> "temp" <.> "s9pk" let path = dir </> "temp" <.> "s9pk"
runConduit $ rawRequestBody .| sinkFile path runConduit $ rawRequestBody .| sinkFile path
pool <- getsYesod appConnPool pool <- getsYesod appConnPool
PkgRepo {..} <- ask PkgRepo{..} <- ask
res <- retry $ extractPkg pool path res <- retry $ extractPkg pool path
when (isNothing res) $ do when (isNothing res) $ do
$logError "Failed to extract package" $logError "Failed to extract package"
sendResponseText status500 "Failed to extract package" sendResponseText status500 "Failed to extract package"
PackageManifest {..} <- liftIO (decodeFileStrict (dir </> "manifest.json")) PackageManifest{..} <-
`orThrow` sendResponseText status500 "Failed to parse manifest.json" liftIO (decodeFileStrict (dir </> "manifest.json"))
`orThrow` sendResponseText status500 "Failed to parse manifest.json"
renameFile path (dir </> (toS . unPkgId) packageManifestId <.> "s9pk") renameFile path (dir </> (toS . unPkgId) packageManifestId <.> "s9pk")
let targetPath = pkgRepoFileRoot </> show packageManifestId </> show packageManifestVersion let targetPath = pkgRepoFileRoot </> show packageManifestId </> show packageManifestVersion
removePathForcibly targetPath removePathForcibly targetPath
@@ -153,92 +174,100 @@ postPkgUploadR = do
Just name -> do Just name -> do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
runDB $ insert_ (Upload (AdminKey name) (PkgRecordKey packageManifestId) packageManifestVersion now) runDB $ insert_ (Upload (AdminKey name) (PkgRecordKey packageManifestId) packageManifestVersion now)
where retry m = runMaybeT . asum $ replicate 3 (MaybeT $ hush <$> try @_ @SomeException m) where
retry m = runMaybeT . asum $ replicate 3 (MaybeT $ hush <$> try @_ @SomeException m)
data IndexPkgReq = IndexPkgReq data IndexPkgReq = IndexPkgReq
{ indexPkgReqId :: !PkgId { indexPkgReqId :: !PkgId
, indexPkgReqVersion :: !Version , indexPkgReqVersion :: !Version
} }
deriving (Eq, Show) deriving (Eq, Show)
instance FromJSON IndexPkgReq where instance FromJSON IndexPkgReq where
parseJSON = withObject "Index Package Request" $ \o -> do parseJSON = withObject "Index Package Request" $ \o -> do
indexPkgReqId <- o .: "id" indexPkgReqId <- o .: "id"
indexPkgReqVersion <- o .: "version" indexPkgReqVersion <- o .: "version"
pure IndexPkgReq { .. } pure IndexPkgReq{..}
instance ToJSON IndexPkgReq where instance ToJSON IndexPkgReq where
toJSON IndexPkgReq {..} = object ["id" .= indexPkgReqId, "version" .= indexPkgReqVersion] toJSON IndexPkgReq{..} = object ["id" .= indexPkgReqId, "version" .= indexPkgReqVersion]
postPkgIndexR :: Handler () postPkgIndexR :: Handler ()
postPkgIndexR = do postPkgIndexR = do
IndexPkgReq {..} <- requireCheckJsonBody IndexPkgReq{..} <- requireCheckJsonBody
manifest <- getManifestLocation indexPkgReqId indexPkgReqVersion manifest <- getManifestLocation indexPkgReqId indexPkgReqVersion
man <- liftIO (decodeFileStrict manifest) `orThrow` sendResponseText man <-
status404 liftIO (decodeFileStrict manifest)
[i|Could not locate manifest for #{indexPkgReqId}@#{indexPkgReqVersion}|] `orThrow` sendResponseText
status404
[i|Could not locate manifest for #{indexPkgReqId}@#{indexPkgReqVersion}|]
pool <- getsYesod appConnPool pool <- getsYesod appConnPool
runSqlPoolNoTransaction (upsertPackageVersion man) pool Nothing runSqlPoolNoTransaction (upsertPackageVersion man) pool Nothing
postPkgDeindexR :: Handler () postPkgDeindexR :: Handler ()
postPkgDeindexR = do postPkgDeindexR = do
IndexPkgReq {..} <- requireCheckJsonBody IndexPkgReq{..} <- requireCheckJsonBody
runDB $ delete (VersionRecordKey (PkgRecordKey indexPkgReqId) indexPkgReqVersion) runDB $ delete (VersionRecordKey (PkgRecordKey indexPkgReqId) indexPkgReqVersion)
newtype PackageList = PackageList { unPackageList :: HashMap PkgId [Version] }
newtype PackageList = PackageList {unPackageList :: HashMap PkgId [Version]}
instance FromJSON PackageList where instance FromJSON PackageList where
parseJSON = fmap PackageList . parseJSON parseJSON = fmap PackageList . parseJSON
instance ToJSON PackageList where instance ToJSON PackageList where
toJSON = toJSON . unPackageList toJSON = toJSON . unPackageList
getPkgDeindexR :: Handler (JSONResponse PackageList) getPkgDeindexR :: Handler (JSONResponse PackageList)
getPkgDeindexR = do getPkgDeindexR = do
dbList <- dbList <-
runDB runDB $
$ (unPkgRecordKey . versionRecordPkgId &&& (: []) . versionRecordNumber) (unPkgRecordKey . versionRecordPkgId &&& (: []) . versionRecordNumber)
. entityVal . entityVal
<<$>> selectList [] [] <<$>> selectList [] []
let inDb = fromListWith (<>) dbList let inDb = fromListWith (<>) dbList
pkgsOnDisk <- getPackages pkgsOnDisk <- getPackages
onDisk <- fromListWith (<>) . zip pkgsOnDisk <$> traverse getVersionsFor pkgsOnDisk onDisk <- fromListWith (<>) . zip pkgsOnDisk <$> traverse getVersionsFor pkgsOnDisk
pure . JSONResponse . PackageList $ filter (not . null) $ differenceWith (guarded null .* (\\)) onDisk inDb pure . JSONResponse . PackageList $ filter (not . null) $ differenceWith (guarded null .* (\\)) onDisk inDb
{-# INLINE (.*) #-}
infixr 8 .*
(.*) :: (b -> c) -> (a1 -> a2 -> b) -> a1 -> a2 -> c
(.*) = (.) . (.)
data AddCategoryReq = AddCategoryReq data AddCategoryReq = AddCategoryReq
{ addCategoryDescription :: !(Maybe Text) { addCategoryDescription :: !(Maybe Text)
, addCategoryPriority :: !(Maybe Int) , addCategoryPriority :: !(Maybe Int)
} }
instance FromJSON AddCategoryReq where instance FromJSON AddCategoryReq where
parseJSON = withObject "AddCategoryReq" $ \o -> do parseJSON = withObject "AddCategoryReq" $ \o -> do
addCategoryDescription <- o .:? "description" addCategoryDescription <- o .:? "description"
addCategoryPriority <- o .:? "priority" addCategoryPriority <- o .:? "priority"
pure AddCategoryReq { .. } pure AddCategoryReq{..}
instance ToJSON AddCategoryReq where instance ToJSON AddCategoryReq where
toJSON AddCategoryReq {..} = object ["description" .= addCategoryDescription, "priority" .= addCategoryPriority] toJSON AddCategoryReq{..} = object ["description" .= addCategoryDescription, "priority" .= addCategoryPriority]
postCategoryR :: Text -> Handler () postCategoryR :: Text -> Handler ()
postCategoryR cat = do postCategoryR cat = do
AddCategoryReq {..} <- requireCheckJsonBody AddCategoryReq{..} <- requireCheckJsonBody
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
void . runDB $ upsert (Category now cat (fromMaybe "" addCategoryDescription) (fromMaybe 0 addCategoryPriority)) [] void . runDB $ upsert (Category now cat (fromMaybe "" addCategoryDescription) (fromMaybe 0 addCategoryPriority)) []
deleteCategoryR :: Text -> Handler () deleteCategoryR :: Text -> Handler ()
deleteCategoryR cat = runDB $ deleteBy (UniqueName cat) deleteCategoryR cat = runDB $ deleteBy (UniqueName cat)
postPkgCategorizeR :: Text -> PkgId -> Handler () postPkgCategorizeR :: Text -> PkgId -> Handler ()
postPkgCategorizeR cat pkg = runDB $ do postPkgCategorizeR cat pkg = runDB $ do
catEnt <- getBy (UniqueName cat) `orThrow` sendResponseText status404 [i|Category "#{cat}" does not exist|] catEnt <- getBy (UniqueName cat) `orThrow` sendResponseText status404 [i|Category "#{cat}" does not exist|]
_pkgEnt <- get (PkgRecordKey pkg) `orThrow` sendResponseText status404 [i|Package "#{pkg}" does not exist|] _pkgEnt <- get (PkgRecordKey pkg) `orThrow` sendResponseText status404 [i|Package "#{pkg}" does not exist|]
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
void $ insertUnique (PkgCategory now (PkgRecordKey pkg) (entityKey catEnt)) `orThrow` sendResponseText void $
status403 insertUnique (PkgCategory now (PkgRecordKey pkg) (entityKey catEnt))
[i|Package "#{pkg}" is already assigned to category "#{cat}"|] `orThrow` sendResponseText
status403
[i|Package "#{pkg}" is already assigned to category "#{cat}"|]
deletePkgCategorizeR :: Text -> PkgId -> Handler () deletePkgCategorizeR :: Text -> PkgId -> Handler ()
deletePkgCategorizeR cat pkg = runDB $ do deletePkgCategorizeR cat pkg = runDB $ do
catEnt <- getBy (UniqueName cat) `orThrow` sendResponseText status404 [i|Category "#{cat}" does not exist|] catEnt <- getBy (UniqueName cat) `orThrow` sendResponseText status404 [i|Category "#{cat}" does not exist|]
deleteBy (UniquePkgCategory (PkgRecordKey pkg) (entityKey catEnt)) deleteBy (UniquePkgCategory (PkgRecordKey pkg) (entityKey catEnt))

113
src/Handler/Apps.hs
View File

@@ -1,113 +0,0 @@
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
module Handler.Apps where
import Startlude ( ($)
, (.)
, Applicative(pure)
, FilePath
, Maybe(..)
, Monad((>>=))
, Show
, String
, show
, void
)
import Control.Monad.Logger ( logError )
import qualified Data.Text as T
import qualified GHC.Show ( Show(..) )
import Network.HTTP.Types ( status404 )
import System.FilePath ( (<.>)
, takeBaseName
)
import Yesod.Core ( Content(ContentFile)
, TypedContent
, addHeader
, notFound
, respond
, respondSource
, sendChunkBS
, sendResponseStatus
, typeJson
, typeOctet
)
import Yesod.Persist.Core ( YesodPersist(runDB) )
import Conduit ( (.|)
, awaitForever
)
import Data.String.Interpolate.IsString
( i )
import Database.Queries ( createMetric
, fetchApp
, fetchAppVersion
)
import Foundation ( Handler )
import Lib.Error ( S9Error(NotFoundE) )
import Lib.PkgRepository ( getBestVersion
, getManifest
, getPackage
)
import Lib.Registry ( S9PK )
import Lib.Types.AppIndex ( PkgId(PkgId) )
import Lib.Types.Emver ( Version )
import Util.Shared ( addPackageHeader
, getVersionSpecFromQuery
, orThrow
, versionPriorityFromQueryIsMin
)
data FileExtension = FileExtension !FilePath !(Maybe String)
instance Show FileExtension where
show (FileExtension f Nothing ) = f
show (FileExtension f (Just e)) = f <.> e
getAppManifestR :: PkgId -> Handler TypedContent
getAppManifestR pkg = do
versionSpec <- getVersionSpecFromQuery
preferMin <- versionPriorityFromQueryIsMin
version <- getBestVersion pkg versionSpec preferMin
`orThrow` sendResponseStatus status404 (NotFoundE [i|#{pkg} satisfying #{versionSpec}|])
addPackageHeader pkg version
(len, src) <- getManifest pkg version
addHeader "Content-Length" (show len)
respondSource typeJson $ src .| awaitForever sendChunkBS
getAppR :: S9PK -> Handler TypedContent
getAppR file = do
let pkg = PkgId . T.pack $ takeBaseName (show file)
versionSpec <- getVersionSpecFromQuery
preferMin <- versionPriorityFromQueryIsMin
version <- getBestVersion pkg versionSpec preferMin
`orThrow` sendResponseStatus status404 (NotFoundE [i|#{pkg} satisfying #{versionSpec}|])
addPackageHeader pkg version
void $ recordMetrics pkg version
pkgPath <- getPackage pkg version >>= \case
Nothing -> sendResponseStatus status404 (NotFoundE [i|#{pkg}@#{version}|])
Just a -> pure a
respond typeOctet $ ContentFile pkgPath Nothing
recordMetrics :: PkgId -> Version -> Handler ()
recordMetrics pkg appVersion = do
sa <- runDB $ fetchApp pkg
case sa of
Nothing -> do
$logError [i|#{pkg} not found in database|]
notFound
Just _ -> do
existingVersion <- runDB $ fetchAppVersion pkg appVersion
case existingVersion of
Nothing -> do
$logError [i|#{pkg}@#{appVersion} not found in database|]
notFound
Just _ -> runDB $ createMetric pkg appVersion

5
src/Handler/Eos.hs Normal file
View File

@@ -0,0 +1,5 @@
module Handler.Eos (module X) where
import Handler.Eos.V0.EosImg as X
import Handler.Eos.V0.Latest as X

53
src/Handler/Eos/V0/EosImg.hs Normal file
View File

@@ -0,0 +1,53 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
module Handler.Eos.V0.EosImg where
import Crypto.Hash (SHA256)
import Crypto.Hash.Conduit (hashFile)
import Data.Attoparsec.Text qualified as Atto
import Data.ByteArray.Encoding (Base (..), convertToBase)
import Data.String.Interpolate.IsString (i)
import Data.Text qualified as T
import Database.Persist (Entity (..), insertUnique)
import Database.Persist.Class (getBy)
import Foundation (Handler, RegistryCtx (..))
import Handler.Util (getVersionSpecFromQuery)
import Lib.Error (S9Error (..))
import Lib.Types.Emver (Version (..), parseVersion, satisfies)
import Model (EosHash (..), Unique (..))
import Network.HTTP.Types (status404)
import Settings (AppSettings (..))
import Startlude (Down (..), FilePath, Maybe (..), Text, decodeUtf8, filter, for_, headMay, partitionEithers, pure, show, sortOn, void, ($), (.), (<$>))
import System.FilePath ((</>))
import UnliftIO.Directory (listDirectory)
import Yesod (Content (..), TypedContent, YesodDB, YesodPersist (runDB), addHeader, getsYesod, respond, sendResponseStatus, typeOctet)
import Yesod.Core (logWarn)
getEosR :: Handler TypedContent
getEosR = do
spec <- getVersionSpecFromQuery
root <- getsYesod $ (</> "eos") . resourcesDir . appSettings
subdirs <- listDirectory root
let (failures, successes) = partitionEithers $ Atto.parseOnly parseVersion . T.pack <$> subdirs
for_ failures $ \f -> $logWarn [i|Emver Parse Failure for EOS: #{f}|]
let mVersion = headMay . sortOn Down . filter (`satisfies` spec) $ successes
case mVersion of
Nothing -> sendResponseStatus status404 (NotFoundE [i|EOS version satisfying #{spec}|])
Just version -> do
let imgPath = root </> show version </> "eos.img"
h <- runDB $ retrieveHash version imgPath
addHeader "x-eos-hash" h
respond typeOctet $ ContentFile imgPath Nothing
where
retrieveHash :: Version -> FilePath -> YesodDB RegistryCtx Text
retrieveHash v fp = do
mHash <- getBy (UniqueVersion v)
case mHash of
Just h -> pure . eosHashHash . entityVal $ h
Nothing -> do
h <- hashFile @_ @SHA256 fp
let t = decodeUtf8 $ convertToBase Base16 h
void $ insertUnique (EosHash v t) -- lazily populate
pure t

65
src/Handler/Eos/V0/Latest.hs Normal file
View File

@@ -0,0 +1,65 @@
{-# LANGUAGE RecordWildCards #-}
module Handler.Eos.V0.Latest where
import Data.Aeson (ToJSON (toJSON), object, (.=))
import Data.HashMap.Strict qualified as HM
import Database.Esqueleto.Experimental (
Entity (entityVal),
desc,
from,
orderBy,
select,
table,
(^.),
)
import Foundation (Handler)
import Handler.Package.V0.ReleaseNotes (ReleaseNotes (..))
import Handler.Util (queryParamAs)
import Lib.Types.Emver (Version, parseVersion)
import Model (EntityField (..), OsVersion (..))
import Orphans.Emver ()
import Startlude (Bool (..), Down (..), Eq, Generic, Maybe, Ord ((<)), Show, Text, const, filter, fst, head, maybe, pure, sortOn, ($), (&&&), (.), (<$>), (<&>))
import Yesod (ToContent (toContent), ToTypedContent (..), YesodPersist (runDB))
import Yesod.Core.Types (JSONResponse (..))
data EosRes = EosRes
{ eosResVersion :: !Version
, eosResHeadline :: !Text
, eosResReleaseNotes :: !ReleaseNotes
}
deriving (Eq, Show, Generic)
instance ToJSON EosRes where
toJSON EosRes{..} =
object ["version" .= eosResVersion, "headline" .= eosResHeadline, "release-notes" .= eosResReleaseNotes]
instance ToContent EosRes where
toContent = toContent . toJSON
instance ToTypedContent EosRes where
toTypedContent = toTypedContent . toJSON
getEosVersionR :: Handler (JSONResponse (Maybe EosRes))
getEosVersionR = do
eosVersion <- queryParamAs "eos-version" parseVersion
allEosVersions <- runDB $
select $ do
vers <- from $ table @OsVersion
orderBy [desc (vers ^. OsVersionCreatedAt)]
pure vers
let osV = entityVal <$> allEosVersions
let mLatest = head osV
let mappedVersions =
ReleaseNotes $
HM.fromList $
sortOn (Down . fst) $
filter (maybe (const True) (<) eosVersion . fst) $
((osVersionNumber &&& osVersionReleaseNotes))
<$> osV
pure . JSONResponse $
mLatest <&> \latest ->
EosRes
{ eosResVersion = osVersionNumber latest
, eosResHeadline = osVersionHeadline latest
, eosResReleaseNotes = mappedVersions
}

66
src/Handler/ErrorLogs.hs
View File

@@ -1,66 +0,0 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
module Handler.ErrorLogs where
import Data.Aeson ( (.:)
, FromJSON(parseJSON)
, withObject
)
import Foundation ( Handler )
import Model ( EntityField(ErrorLogRecordIncidents)
, ErrorLogRecord(ErrorLogRecord)
)
import Startlude ( ($)
, Applicative(pure)
, Eq
, MonadIO(liftIO)
, Show
, Text
, Word32
, getCurrentTime
, void
)
import Yesod.Core ( requireCheckJsonBody )
import Yesod.Persist ( (+=.)
, runDB
, upsert
)
data ErrorLog = ErrorLog
{ errorLogEpoch :: !Text
, errorLogCommitHash :: !Text
, errorLogSourceFile :: !Text
, errorLogLine :: !Word32
, errorLogTarget :: !Text
, errorLogLevel :: !Text
, errorLogMessage :: !Text
}
deriving (Eq, Show)
instance FromJSON ErrorLog where
parseJSON = withObject "Error Log" $ \o -> do
errorLogEpoch <- o .: "log-epoch"
errorLogCommitHash <- o .: "commit-hash"
errorLogSourceFile <- o .: "file"
errorLogLine <- o .: "line"
errorLogLevel <- o .: "level"
errorLogTarget <- o .: "target"
errorLogMessage <- o .: "log-message"
pure ErrorLog { .. }
postErrorLogsR :: Handler ()
postErrorLogsR = do
ErrorLog {..} <- requireCheckJsonBody @_ @ErrorLog
void $ runDB $ do
now <- liftIO getCurrentTime
let logRecord = ErrorLogRecord now
errorLogEpoch
errorLogCommitHash
errorLogSourceFile
errorLogLine
errorLogTarget
errorLogLevel
errorLogMessage
1
upsert logRecord [ErrorLogRecordIncidents +=. 1]

80
src/Handler/Icons.hs
View File

@@ -1,80 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Handler.Icons where
import Startlude ( ($)
, Eq
, Generic
, Read
, Show
, show
)
import Data.Conduit ( (.|)
, awaitForever
)
import Data.String.Interpolate.IsString
( i )
import Foundation ( Handler )
import Lib.Error ( S9Error(NotFoundE) )
import Lib.PkgRepository ( getBestVersion
, getIcon
, getInstructions
, getLicense
)
import Lib.Types.AppIndex ( PkgId )
import Network.HTTP.Types ( status400 )
import Util.Shared ( getVersionSpecFromQuery
, orThrow
, versionPriorityFromQueryIsMin
)
import Yesod.Core ( FromJSON
, ToJSON
, TypedContent
, addHeader
, respondSource
, sendChunkBS
, sendResponseStatus
, typePlain
)
data IconType = PNG | JPG | JPEG | SVG
deriving (Eq, Show, Generic, Read)
instance ToJSON IconType
instance FromJSON IconType
getIconsR :: PkgId -> Handler TypedContent
getIconsR pkg = do
spec <- getVersionSpecFromQuery
preferMin <- versionPriorityFromQueryIsMin
version <- getBestVersion pkg spec preferMin
`orThrow` sendResponseStatus status400 (NotFoundE [i|Icon for #{pkg} satisfying #{spec}|])
(ct, len, src) <- getIcon pkg version
addHeader "Content-Length" (show len)
respondSource ct $ src .| awaitForever sendChunkBS
getLicenseR :: PkgId -> Handler TypedContent
getLicenseR pkg = do
spec <- getVersionSpecFromQuery
preferMin <- versionPriorityFromQueryIsMin
version <- getBestVersion pkg spec preferMin
`orThrow` sendResponseStatus status400 (NotFoundE [i|License for #{pkg} satisfying #{spec}|])
(len, src) <- getLicense pkg version
addHeader "Content-Length" (show len)
respondSource typePlain $ src .| awaitForever sendChunkBS
getInstructionsR :: PkgId -> Handler TypedContent
getInstructionsR pkg = do
spec <- getVersionSpecFromQuery
preferMin <- versionPriorityFromQueryIsMin
version <- getBestVersion pkg spec preferMin
`orThrow` sendResponseStatus status400 (NotFoundE [i|Instructions for #{pkg} satisfying #{spec}|])
(len, src) <- getInstructions pkg version
addHeader "Content-Length" (show len)
respondSource typePlain $ src .| awaitForever sendChunkBS

451
src/Handler/Marketplace.hs
View File

@@ -1,451 +0,0 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Redundant <$>" #-}
module Handler.Marketplace where
import Startlude ( ($)
, (&&&)
, (.)
, (<$>)
, (<&>)
, Applicative((*>), pure)
, Bool(True)
, ByteString
, Down(Down)
, Either(Left, Right)
, FilePath
, Foldable(foldMap)
, Functor(fmap)
, Int
, Maybe(..)
, Monad((>>=))
, MonadIO
, MonadReader
, Monoid(mappend)
, Num((*), (-))
, Ord((<))
, ReaderT(runReaderT)
, Text
, Traversable(traverse)
, catMaybes
, const
, decodeUtf8
, encodeUtf8
, filter
, flip
, for_
, fromMaybe
, fst
, head
, headMay
, id
, maybe
, partitionEithers
, readMaybe
, show
, snd
, void
)
import Conduit ( (.|)
, dropC
, runConduit
, sinkList
, takeC
)
import Control.Monad.Logger ( MonadLogger
, logWarn
)
import Control.Monad.Reader.Has ( Has
, ask
)
import Crypto.Hash ( SHA256 )
import Crypto.Hash.Conduit ( hashFile )
import Data.Aeson ( decode
, eitherDecode
, eitherDecodeStrict
)
import qualified Data.Attoparsec.Text as Atto
import Data.Attoparsec.Text ( Parser
, parseOnly
)
import Data.ByteArray.Encoding ( Base(..)
, convertToBase
)
import Data.ByteString.Base64 ( encodeBase64 )
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Conduit.List as CL
import qualified Data.HashMap.Strict as HM
import Data.List ( lookup
, sortOn
)
import Data.String.Interpolate.IsString
( i )
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TB
import Database.Esqueleto.Experimental
( Entity(entityKey, entityVal)
, SqlBackend
, (^.)
, asc
, desc
, from
, orderBy
, select
, table
)
import Database.Marketplace ( collateVersions
, fetchAllAppVersions
, fetchLatestApp
, getPkgData
, getPkgDependencyData
, searchServices
, zipCategories
, zipDependencyVersions
)
import Database.Persist ( PersistUniqueRead(getBy)
, insertUnique
)
import Foundation ( Handler
, RegistryCtx(appConnPool, appSettings)
, Route(InstructionsR, LicenseR)
)
import Handler.Types.Marketplace ( CategoryTitle
, DependencyRes(..)
, EosRes(..)
, InfoRes(InfoRes)
, OrderArrangement(DESC)
, PackageListDefaults
( PackageListDefaults
, packageListCategory
, packageListOrder
, packageListPageLimit
, packageListPageNumber
, packageListQuery
)
, PackageListRes(..)
, PackageMetadata(..)
, PackageReq(packageReqId, packageReqVersion)
, PackageRes(..)
, ReleaseNotes(ReleaseNotes)
, VersionLatestRes(..)
)
import Lib.Error ( S9Error(..) )
import Lib.PkgRepository ( PkgRepo
, getIcon
, getManifest
)
import Lib.Types.AppIndex ( PkgId )
import Lib.Types.Emver ( Version
, VersionRange
, parseRange
, parseVersion
, satisfies
)
import Model ( Category(..)
, EntityField(..)
, EosHash(EosHash, eosHashHash)
, Key(PkgRecordKey, unPkgRecordKey)
, OsVersion(..)
, PkgRecord(..)
, Unique(UniqueVersion)
, VersionRecord(..)
)
import Network.HTTP.Types ( status400
, status404
)
import Protolude.Unsafe ( unsafeFromJust )
import Settings ( AppSettings(marketplaceName, resourcesDir) )
import System.FilePath ( (</>) )
import UnliftIO.Async ( mapConcurrently )
import UnliftIO.Directory ( listDirectory )
import Util.Shared ( filterDependencyBestVersion
, filterDependencyOsCompatible
, filterLatestVersionFromSpec
, filterPkgOsCompatible
, getVersionSpecFromQuery
)
import Yesod.Core ( Content(ContentFile)
, MonadHandler
, MonadResource
, RenderRoute(renderRoute)
, TypedContent
, YesodRequest(..)
, addHeader
, getRequest
, getYesod
, getsYesod
, lookupGetParam
, respond
, sendResponseStatus
, typeOctet
)
import Yesod.Core.Types ( JSONResponse(..) )
import Yesod.Persist ( YesodDB )
import Yesod.Persist.Core ( YesodPersist(runDB) )
queryParamAs :: MonadHandler m => Text -> Parser a -> m (Maybe a)
queryParamAs k p = lookupGetParam k >>= \case
Nothing -> pure Nothing
Just x -> case parseOnly p x of
Left e ->
sendResponseStatus @_ @Text status400 [i|Invalid Request! The query parameter '#{k}' failed to parse: #{e}|]
Right a -> pure (Just a)
getInfoR :: Handler (JSONResponse InfoRes)
getInfoR = do
name <- getsYesod $ marketplaceName . appSettings
allCategories <- runDB $ select $ do
cats <- from $ table @Category
orderBy [asc (cats ^. CategoryPriority)]
pure cats
pure $ JSONResponse $ InfoRes name $ categoryName . entityVal <$> allCategories
getEosVersionR :: Handler (JSONResponse (Maybe EosRes))
getEosVersionR = do
eosVersion <- queryParamAs "eos-version" parseVersion
allEosVersions <- runDB $ select $ do
vers <- from $ table @OsVersion
orderBy [desc (vers ^. OsVersionCreatedAt)]
pure vers
let osV = entityVal <$> allEosVersions
let mLatest = head osV
let mappedVersions =
ReleaseNotes
$ HM.fromList
$ sortOn (Down . fst)
$ filter (maybe (const True) (<) eosVersion . fst)
$ (\v -> (osVersionNumber v, osVersionReleaseNotes v))
<$> osV
pure . JSONResponse $ mLatest <&> \latest -> EosRes { eosResVersion = osVersionNumber latest
, eosResHeadline = osVersionHeadline latest
, eosResReleaseNotes = mappedVersions
}
getReleaseNotesR :: PkgId -> Handler ReleaseNotes
getReleaseNotesR pkg = do
appConnPool <- appConnPool <$> getYesod
versionRecords <- runDB $ fetchAllAppVersions appConnPool pkg
pure $ constructReleaseNotesApiRes versionRecords
where
constructReleaseNotesApiRes :: [VersionRecord] -> ReleaseNotes
constructReleaseNotesApiRes vers = do
ReleaseNotes
$ HM.fromList
$ sortOn (Down . fst)
$ (versionRecordNumber &&& versionRecordReleaseNotes)
<$> vers
getEosR :: Handler TypedContent
getEosR = do
spec <- getVersionSpecFromQuery
root <- getsYesod $ (</> "eos") . resourcesDir . appSettings
subdirs <- listDirectory root
let (failures, successes) = partitionEithers $ Atto.parseOnly parseVersion . T.pack <$> subdirs
for_ failures $ \f -> $logWarn [i|Emver Parse Failure for EOS: #{f}|]
let mVersion = headMay . sortOn Down . filter (`satisfies` spec) $ successes
case mVersion of
Nothing -> sendResponseStatus status404 (NotFoundE [i|EOS version satisfying #{spec}|])
Just version -> do
let imgPath = root </> show version </> "eos.img"
h <- runDB $ retrieveHash version imgPath
addHeader "x-eos-hash" h
respond typeOctet $ ContentFile imgPath Nothing
where
retrieveHash :: Version -> FilePath -> YesodDB RegistryCtx Text
retrieveHash v fp = do
mHash <- getBy (UniqueVersion v)
case mHash of
Just h -> pure . eosHashHash . entityVal $ h
Nothing -> do
h <- hashFile @_ @SHA256 fp
let t = decodeUtf8 $ convertToBase Base16 h
void $ insertUnique (EosHash v t) -- lazily populate
pure t
-- TODO refactor with conduit
getVersionLatestR :: Handler VersionLatestRes
getVersionLatestR = do
getParameters <- reqGetParams <$> getRequest
case lookup "ids" getParameters of
Nothing -> sendResponseStatus status400 (InvalidParamsE "get:ids" "<MISSING>")
Just packages -> case eitherDecode $ LBS.fromStrict $ encodeUtf8 packages of
Left _ -> sendResponseStatus status400 (InvalidParamsE "get:ids" packages)
Right p -> do
let packageList = (, Nothing) <$> p
found <- runDB $ traverse fetchLatestApp $ fst <$> packageList
pure
$ VersionLatestRes
$ HM.union
( HM.fromList
$ (\v ->
(unPkgRecordKey . entityKey $ fst v, Just $ versionRecordNumber $ entityVal $ snd v)
)
<$> catMaybes found
)
$ HM.fromList packageList
getPackageListR :: Handler PackageListRes
getPackageListR = do
osPredicate <- getOsVersionQuery <&> \case
Nothing -> const True
Just v -> flip satisfies v
pkgIds <- getPkgIdsQuery
filteredPackages <- case pkgIds of
Nothing -> do
-- query for all
category <- getCategoryQuery
page <- getPageQuery
limit' <- getLimitQuery
query <- T.strip . fromMaybe (packageListQuery defaults) <$> lookupGetParam "query"
runDB
$ runConduit
$ searchServices category query
.| collateVersions
.| zipCategories
-- empty list since there are no requested packages in this case
.| filterLatestVersionFromSpec []
.| filterPkgOsCompatible osPredicate
-- pages start at 1 for some reason. TODO: make pages start at 0
.| (dropC (limit' * (page - 1)) *> takeC limit')
.| sinkList
Just packages' -> do
-- for each item in list get best available from version range
let vMap = (packageReqId &&& packageReqVersion) <$> packages'
runDB
-- TODO could probably be better with sequenceConduits
. runConduit
$ getPkgData (packageReqId <$> packages')
.| collateVersions
.| zipCategories
.| filterLatestVersionFromSpec vMap
.| filterPkgOsCompatible osPredicate
.| sinkList
-- NOTE: if a package's dependencies do not meet the system requirements, it is currently omitted from the list
pkgsWithDependencies <- runDB $ mapConcurrently (getPackageDependencies osPredicate) filteredPackages
PackageListRes <$> mapConcurrently constructPackageListApiRes pkgsWithDependencies
where
defaults = PackageListDefaults { packageListOrder = DESC
, packageListPageLimit = 20
, packageListPageNumber = 1
, packageListCategory = Nothing
, packageListQuery = ""
}
getPkgIdsQuery :: Handler (Maybe [PackageReq])
getPkgIdsQuery = lookupGetParam "ids" >>= \case
Nothing -> pure Nothing
Just ids -> case eitherDecodeStrict (encodeUtf8 ids) of
Left _ -> do
let e = InvalidParamsE "get:ids" ids
$logWarn (show e)
sendResponseStatus status400 e
Right a -> pure a
getCategoryQuery :: Handler (Maybe CategoryTitle)
getCategoryQuery = lookupGetParam "category" >>= \case
Nothing -> pure Nothing
Just c -> case readMaybe . T.toUpper $ c of
Nothing -> do
let e = InvalidParamsE "get:category" c
$logWarn (show e)
sendResponseStatus status400 e
Just t -> pure $ Just t
getPageQuery :: Handler Int
getPageQuery = lookupGetParam "page" >>= \case
Nothing -> pure $ packageListPageNumber defaults
Just p -> case readMaybe p of
Nothing -> do
let e = InvalidParamsE "get:page" p
$logWarn (show e)
sendResponseStatus status400 e
Just t -> pure $ case t of
0 -> 1 -- disallow page 0 so offset is not negative
_ -> t
getLimitQuery :: Handler Int
getLimitQuery = lookupGetParam "per-page" >>= \case
Nothing -> pure $ packageListPageLimit defaults
Just pp -> case readMaybe pp of
Nothing -> do
let e = InvalidParamsE "get:per-page" pp
$logWarn (show e)
sendResponseStatus status400 e
Just l -> pure l
getOsVersionQuery :: Handler (Maybe VersionRange)
getOsVersionQuery = lookupGetParam "eos-version-compat" >>= \case
Nothing -> pure Nothing
Just osv -> case Atto.parseOnly parseRange osv of
Left _ -> do
let e = InvalidParamsE "get:eos-version-compat" osv
$logWarn (show e)
sendResponseStatus status400 e
Right v -> pure $ Just v
getPackageDependencies :: (MonadIO m, MonadLogger m)
=> (Version -> Bool)
-> PackageMetadata
-> ReaderT
SqlBackend
m
( Key PkgRecord
, [Category]
, [Version]
, Version
, [(Key PkgRecord, Text, Version)]
)
getPackageDependencies osPredicate PackageMetadata { packageMetadataPkgId = pkg, packageMetadataPkgVersionRecords = pkgVersions, packageMetadataPkgCategories = pkgCategories, packageMetadataPkgVersion = pkgVersion }
= do
let pkgId = PkgRecordKey pkg
let pkgVersions' = versionRecordNumber . entityVal <$> pkgVersions
let pkgCategories' = entityVal <$> pkgCategories
pkgDepInfo <- getPkgDependencyData pkgId pkgVersion
pkgDepInfoWithVersions <- traverse zipDependencyVersions pkgDepInfo
let compatiblePkgDepInfo = fmap (filterDependencyOsCompatible osPredicate) pkgDepInfoWithVersions
res <- catMaybes <$> traverse filterDependencyBestVersion compatiblePkgDepInfo
pure (pkgId, pkgCategories', pkgVersions', pkgVersion, res)
constructPackageListApiRes :: (MonadResource m, MonadReader r m, Has AppSettings r, Has PkgRepo r)
=> ( Key PkgRecord
, [Category]
, [Version]
, Version
, [(Key PkgRecord, Text, Version)]
)
-> m PackageRes
constructPackageListApiRes (pkgKey, pkgCategories, pkgVersions, pkgVersion, dependencies) = do
settings <- ask @_ @_ @AppSettings
let pkgId = unPkgRecordKey pkgKey
manifest <- flip runReaderT settings $ (snd <$> getManifest pkgId pkgVersion) >>= \bs ->
runConduit $ bs .| CL.foldMap LBS.fromStrict
icon <- loadIcon pkgId pkgVersion
deps <- constructDependenciesApiRes dependencies
pure $ PackageRes { packageResIcon = encodeBase64 icon -- pass through raw JSON Value, we have checked its correct parsing above
, packageResManifest = unsafeFromJust . decode $ manifest
, packageResCategories = categoryName <$> pkgCategories
, packageResInstructions = basicRender $ InstructionsR pkgId
, packageResLicense = basicRender $ LicenseR pkgId
, packageResVersions = pkgVersions
, packageResDependencies = HM.fromList deps
}
constructDependenciesApiRes :: (MonadResource m, MonadReader r m, Has PkgRepo r)
=> [(Key PkgRecord, Text, Version)]
-> m [(PkgId, DependencyRes)]
constructDependenciesApiRes deps = traverse
(\(depKey, depTitle, depVersion) -> do
let depId = unPkgRecordKey depKey
icon <- loadIcon depId depVersion
pure (depId, DependencyRes { dependencyResTitle = depTitle, dependencyResIcon = encodeBase64 icon })
)
deps
loadIcon :: (MonadResource m, MonadReader r m, Has PkgRepo r) => PkgId -> Version -> m ByteString
loadIcon pkg version = do
(_, _, src) <- getIcon pkg version
runConduit $ src .| CL.foldMap id
basicRender :: RenderRoute a => Route a -> Text
basicRender = TL.toStrict . TB.toLazyText . foldMap (mappend (TB.singleton '/') . TB.fromText) . fst . renderRoute

59
src/Handler/Package.hs Normal file
View File

@@ -0,0 +1,59 @@
module Handler.Package where
import Foundation (Handler)
import Handler.Package.V0.Icon qualified
import Handler.Package.V0.Index (PackageListRes, getPackageIndexR)
import Handler.Package.V0.Info (InfoRes, getInfoR)
import Handler.Package.V0.Instructions qualified
import Handler.Package.V0.Latest (VersionLatestRes, getVersionLatestR)
import Handler.Package.V0.License qualified
import Handler.Package.V0.Manifest qualified
import Handler.Package.V0.ReleaseNotes (ReleaseNotes, getReleaseNotesR)
import Handler.Package.V0.S9PK qualified
import Handler.Package.V0.Version (AppVersionRes, getPkgVersionR)
import Handler.Types.Api (ApiVersion (..))
import Lib.Types.Core (PkgId, S9PK)
import Yesod.Core.Types (
JSONResponse,
TypedContent,
)
getInfoR :: ApiVersion -> Handler (JSONResponse InfoRes)
getInfoR _ = Handler.Package.V0.Info.getInfoR
getPackageIndexR :: ApiVersion -> Handler PackageListRes
getPackageIndexR _ = Handler.Package.V0.Index.getPackageIndexR
getVersionLatestR :: ApiVersion -> Handler VersionLatestRes
getVersionLatestR _ = Handler.Package.V0.Latest.getVersionLatestR
getAppR :: ApiVersion -> S9PK -> Handler TypedContent
getAppR _ = Handler.Package.V0.S9PK.getAppR
getAppManifestR :: ApiVersion -> PkgId -> Handler TypedContent
getAppManifestR _ = Handler.Package.V0.Manifest.getAppManifestR
getReleaseNotesR :: ApiVersion -> PkgId -> Handler ReleaseNotes
getReleaseNotesR _ = Handler.Package.V0.ReleaseNotes.getReleaseNotesR
getIconsR :: ApiVersion -> PkgId -> Handler TypedContent
getIconsR _ = Handler.Package.V0.Icon.getIconsR
getLicenseR :: ApiVersion -> PkgId -> Handler TypedContent
getLicenseR _ = Handler.Package.V0.License.getLicenseR
getInstructionsR :: ApiVersion -> PkgId -> Handler TypedContent
getInstructionsR _ = Handler.Package.V0.Instructions.getInstructionsR
getPkgVersionR :: ApiVersion -> PkgId -> Handler AppVersionRes
getPkgVersionR _ = Handler.Package.V0.Version.getPkgVersionR

32
src/Handler/Package/V0/Icon.hs Normal file
View File

@@ -0,0 +1,32 @@
{-# LANGUAGE QuasiQuotes #-}
module Handler.Package.V0.Icon where
import Conduit (awaitForever, (.|))
import Data.String.Interpolate.IsString (
i,
)
import Foundation (Handler)
import Handler.Util (
getVersionSpecFromQuery,
orThrow,
versionPriorityFromQueryIsMin,
)
import Lib.Error (S9Error (..))
import Lib.PkgRepository (getBestVersion, getIcon)
import Lib.Types.Core (PkgId)
import Network.HTTP.Types (status400)
import Startlude (show, ($))
import Yesod (TypedContent, addHeader, respondSource, sendChunkBS, sendResponseStatus)
getIconsR :: PkgId -> Handler TypedContent
getIconsR pkg = do
spec <- getVersionSpecFromQuery
preferMin <- versionPriorityFromQueryIsMin
version <-
getBestVersion pkg spec preferMin
`orThrow` sendResponseStatus status400 (NotFoundE [i|Icon for #{pkg} satisfying #{spec}|])
(ct, len, src) <- getIcon pkg version
addHeader "Content-Length" (show len)
respondSource ct $ src .| awaitForever sendChunkBS

302
src/Handler/Package/V0/Index.hs Normal file
View File

@@ -0,0 +1,302 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
module Handler.Package.V0.Index where
import Conduit (concatMapC, dropC, mapC, mapMC, runConduit, sinkList, takeC, (.|))
import Control.Monad.Reader.Has (Functor (fmap), Has, Monad ((>>=)), MonadReader, ReaderT (runReaderT), ask, lift)
import Data.Aeson (FromJSON (..), ToJSON (..), Value, decode, eitherDecodeStrict, object, withObject, (.:), (.=))
import Data.Attoparsec.Text qualified as Atto
import Data.ByteString.Base64 (encodeBase64)
import Data.ByteString.Lazy qualified as LBS
import Data.Conduit.List qualified as CL
import Data.HashMap.Internal.Strict (HashMap)
import Data.HashMap.Strict qualified as HM
import Data.List (lookup)
import Data.List.NonEmpty qualified as NE
import Data.Text qualified as T
import Database.Persist.Sql (SqlBackend)
import Database.Queries (
collateVersions,
getCategoriesFor,
getDependencyVersions,
getPkgDataSource,
getPkgDependencyData,
serviceQuerySource,
)
import Foundation (Handler, Route (InstructionsR, LicenseR))
import Handler.Types.Api (ApiVersion (..))
import Handler.Util (basicRender)
import Lib.Error (S9Error (..))
import Lib.PkgRepository (PkgRepo, getIcon, getManifest)
import Lib.Types.Core (PkgId)
import Lib.Types.Emver (Version, VersionRange (..), parseRange, satisfies, (<||))
import Model (Category (..), Key (..), PkgDependency (..), VersionRecord (..))
import Network.HTTP.Types (status400)
import Protolude.Unsafe (unsafeFromJust)
import Settings (AppSettings)
import Startlude (
Applicative ((*>)),
Bifunctor (..),
Bool (..),
ByteString,
ConvertText (toS),
Down (..),
Either (..),
Eq (..),
Generic,
Int,
Maybe (..),
MonadIO,
NonEmpty,
Num ((*), (-)),
Show,
Text,
Traversable (traverse),
catMaybes,
const,
encodeUtf8,
filter,
flip,
for,
fromMaybe,
headMay,
id,
mappend,
maximumOn,
nonEmpty,
note,
pure,
readMaybe,
snd,
sortOn,
zipWith,
zipWithM,
($),
(&&&),
(.),
(.*),
(<$>),
(<&>),
(<>),
(=<<),
)
import UnliftIO (Concurrently (..), mapConcurrently)
import Yesod (
MonadLogger,
MonadResource,
ToContent (..),
ToTypedContent (..),
YesodPersist (runDB),
lookupGetParam,
sendResponseStatus,
)
import Yesod.Core (logWarn)
data PackageReq = PackageReq
{ packageReqId :: !PkgId
, packageReqVersion :: !VersionRange
}
deriving (Show)
instance FromJSON PackageReq where
parseJSON = withObject "package version" $ \o -> do
packageReqId <- o .: "id"
packageReqVersion <- o .: "version"
pure PackageReq{..}
data PackageRes = PackageRes
{ packageResIcon :: !Text
, packageResManifest :: !Value -- PackageManifest
, packageResCategories :: ![Text]
, packageResInstructions :: !Text
, packageResLicense :: !Text
, packageResVersions :: !(NonEmpty Version)
, packageResDependencies :: !(HashMap PkgId DependencyRes)
}
deriving (Show, Generic)
instance ToJSON PackageRes where
toJSON PackageRes{..} =
object
[ "icon" .= packageResIcon
, "license" .= packageResLicense
, "instructions" .= packageResInstructions
, "manifest" .= packageResManifest
, "categories" .= packageResCategories
, "versions" .= packageResVersions
, "dependency-metadata" .= packageResDependencies
]
newtype PackageListRes = PackageListRes [PackageRes]
deriving (Generic)
instance ToJSON PackageListRes
instance ToContent PackageListRes where
toContent = toContent . toJSON
instance ToTypedContent PackageListRes where
toTypedContent = toTypedContent . toJSON
data DependencyRes = DependencyRes
{ dependencyResTitle :: !Text
, dependencyResIcon :: !Text
}
deriving (Eq, Show)
instance ToJSON DependencyRes where
toJSON DependencyRes{..} = object ["icon" .= dependencyResIcon, "title" .= dependencyResTitle]
data PackageMetadata = PackageMetadata
{ packageMetadataPkgId :: !PkgId
, packageMetadataPkgVersionRecords :: !(NonEmpty VersionRecord)
, packageMetadataPkgVersion :: !Version
, packageMetadataPkgCategories :: ![Category]
}
deriving (Eq, Show)
getPackageIndexR :: Handler PackageListRes
getPackageIndexR = do
osPredicate <-
getOsVersionQuery <&> \case
Nothing -> const True
Just v -> flip satisfies v
pkgIds <- getPkgIdsQuery
category <- getCategoryQuery
page <- fromMaybe 1 <$> getPageQuery
limit' <- fromMaybe 20 <$> getLimitQuery
query <- T.strip . fromMaybe "" <$> lookupGetParam "query"
let (source, packageRanges) = case pkgIds of
Nothing -> (serviceQuerySource category query, const Any)
Just packages ->
let s = getPkgDataSource (packageReqId <$> packages)
r = fromMaybe None . (flip lookup $ (packageReqId &&& packageReqVersion) <$> packages)
in (s, r)
filteredPackages <-
runDB $
runConduit $
source
-- group conduit pipeline by pkg id
.| collateVersions
-- filter out versions of apps that are incompatible with the OS predicate
.| mapC (second (filter (osPredicate . versionRecordOsVersion)))
-- prune empty version sets
.| concatMapC (\(pkgId, vs) -> (pkgId,) <$> nonEmpty vs)
-- grab the latest matching version if it exists
.| concatMapC (\(a, b) -> (a,b,) <$> (selectLatestVersionFromSpec packageRanges b))
-- construct
.| mapMC (\(a, b, c) -> PackageMetadata a b (versionRecordNumber c) <$> getCategoriesFor a)
-- pages start at 1 for some reason. TODO: make pages start at 0
.| (dropC (limit' * (page - 1)) *> takeC limit')
.| sinkList
-- NOTE: if a package's dependencies do not meet the system requirements, it is currently omitted from the list
pkgsWithDependencies <- runDB $ mapConcurrently (getPackageDependencies osPredicate) filteredPackages
PackageListRes <$> runConcurrently (zipWithM (Concurrently .* constructPackageListApiRes) filteredPackages pkgsWithDependencies)
parseQueryParam :: Text -> (Text -> Either Text a) -> Handler (Maybe a)
parseQueryParam param parser = do
lookupGetParam param >>= \case
Nothing -> pure Nothing
Just x -> case parser x of
Left e -> do
let err = InvalidParamsE ("get:" <> param) x
$logWarn e
sendResponseStatus status400 err
Right a -> pure (Just a)
getPkgIdsQuery :: Handler (Maybe [PackageReq])
getPkgIdsQuery = parseQueryParam "ids" (first toS . eitherDecodeStrict . encodeUtf8)
getCategoryQuery :: Handler (Maybe Text)
getCategoryQuery = parseQueryParam "category" ((flip $ note . mappend "Invalid 'category': ") =<< (readMaybe . T.toUpper))
getPageQuery :: Handler (Maybe Int)
getPageQuery = parseQueryParam "page" ((flip $ note . mappend "Invalid 'page': ") =<< readMaybe)
getLimitQuery :: Handler (Maybe Int)
getLimitQuery = parseQueryParam "per-page" ((flip $ note . mappend "Invalid 'per-page': ") =<< readMaybe)
getOsVersionQuery :: Handler (Maybe VersionRange)
getOsVersionQuery = parseQueryParam "eos-version-compat" (first toS . Atto.parseOnly parseRange)
getPackageDependencies ::
(MonadIO m, MonadLogger m, MonadResource m, Has PkgRepo r, MonadReader r m) =>
(Version -> Bool) ->
PackageMetadata ->
ReaderT SqlBackend m (HashMap PkgId DependencyRes)
getPackageDependencies osPredicate PackageMetadata{packageMetadataPkgId = pkg, packageMetadataPkgVersion = pkgVersion} =
do
pkgDepInfo <- getPkgDependencyData pkg pkgVersion
pkgDepInfoWithVersions <- traverse getDependencyVersions pkgDepInfo
let compatiblePkgDepInfo = fmap (filter (osPredicate . versionRecordOsVersion)) pkgDepInfoWithVersions
let depMetadata = catMaybes $ zipWith selectDependencyBestVersion pkgDepInfo compatiblePkgDepInfo
lift $
fmap HM.fromList $
for depMetadata $ \(depId, title, v) -> do
icon <- encodeBase64 <$> loadIcon depId v
pure $ (depId, DependencyRes title icon)
constructPackageListApiRes ::
(MonadResource m, MonadReader r m, Has AppSettings r, Has PkgRepo r) =>
PackageMetadata ->
HashMap PkgId DependencyRes ->
m PackageRes
constructPackageListApiRes PackageMetadata{..} dependencies = do
settings <- ask @_ @_ @AppSettings
let pkgId = packageMetadataPkgId
let pkgCategories = packageMetadataPkgCategories
let pkgVersions = packageMetadataPkgVersionRecords
let pkgVersion = packageMetadataPkgVersion
manifest <-
flip runReaderT settings $
(snd <$> getManifest pkgId pkgVersion) >>= \bs ->
runConduit $ bs .| CL.foldMap LBS.fromStrict
icon <- loadIcon pkgId pkgVersion
pure $
PackageRes
{ packageResIcon = encodeBase64 icon -- pass through raw JSON Value, we have checked its correct parsing above
, packageResManifest = unsafeFromJust . decode $ manifest
, packageResCategories = categoryName <$> pkgCategories
, packageResInstructions = basicRender $ InstructionsR V0 pkgId
, packageResLicense = basicRender $ LicenseR V0 pkgId
, packageResVersions = versionRecordNumber <$> pkgVersions
, packageResDependencies = dependencies
}
loadIcon :: (MonadResource m, MonadReader r m, Has PkgRepo r) => PkgId -> Version -> m ByteString
loadIcon pkg version = do
(_, _, src) <- getIcon pkg version
runConduit $ src .| CL.foldMap id
selectLatestVersionFromSpec ::
(PkgId -> VersionRange) ->
NonEmpty VersionRecord ->
Maybe VersionRecord
selectLatestVersionFromSpec pkgRanges vs =
let pkgId = NE.head $ versionRecordPkgId <$> vs
spec = pkgRanges (unPkgRecordKey pkgId)
in headMay . sortOn (Down . versionRecordNumber) $ NE.filter ((`satisfies` spec) . versionRecordNumber) vs
-- get best version of the dependency based on what is specified in the db (ie. what is specified in the manifest for the package)
selectDependencyBestVersion :: PkgDependency -> [VersionRecord] -> Maybe (PkgId, Text, Version)
selectDependencyBestVersion pkgDepRecord depVersions = do
let depId = pkgDependencyDepId pkgDepRecord
let versionRequirement = pkgDependencyDepVersionRange pkgDepRecord
let satisfactory = filter ((<|| versionRequirement) . versionRecordNumber) depVersions
case maximumOn versionRecordNumber satisfactory of
Just bestVersion -> Just (unPkgRecordKey depId, versionRecordTitle bestVersion, versionRecordNumber bestVersion)
Nothing -> Nothing

33
src/Handler/Package/V0/Info.hs Normal file
View File

@@ -0,0 +1,33 @@
module Handler.Package.V0.Info where
import Data.Aeson (ToJSON (..))
import Database.Esqueleto.Experimental (Entity (..), asc, from, orderBy, select, table, (^.))
import Foundation (Handler, RegistryCtx (..))
import Model (Category (..), EntityField (..))
import Settings (AppSettings (..))
import Startlude (Generic, Show, Text, pure, ($), (.), (<$>))
import Yesod (ToContent (..), ToTypedContent (..), YesodPersist (runDB), getsYesod)
import Yesod.Core.Types (JSONResponse (..))
data InfoRes = InfoRes
{ name :: !Text
, categories :: ![Text]
}
deriving (Show, Generic)
instance ToJSON InfoRes
instance ToContent InfoRes where
toContent = toContent . toJSON
instance ToTypedContent InfoRes where
toTypedContent = toTypedContent . toJSON
getInfoR :: Handler (JSONResponse InfoRes)
getInfoR = do
name <- getsYesod $ marketplaceName . appSettings
allCategories <- runDB $
select $ do
cats <- from $ table @Category
orderBy [asc (cats ^. CategoryPriority)]
pure cats
pure $ JSONResponse $ InfoRes name $ categoryName . entityVal <$> allCategories

26
src/Handler/Package/V0/Instructions.hs Normal file
View File

@@ -0,0 +1,26 @@
{-# LANGUAGE QuasiQuotes #-}
module Handler.Package.V0.Instructions where
import Conduit (awaitForever, (.|))
import Data.String.Interpolate.IsString (i)
import Foundation (Handler)
import Handler.Util (getVersionSpecFromQuery, orThrow, versionPriorityFromQueryIsMin)
import Lib.Error (S9Error (..))
import Lib.PkgRepository (getBestVersion, getInstructions)
import Lib.Types.Core (PkgId)
import Network.HTTP.Types (status400)
import Startlude (show, ($))
import Yesod (TypedContent, addHeader, respondSource, sendChunkBS, sendResponseStatus, typePlain)
getInstructionsR :: PkgId -> Handler TypedContent
getInstructionsR pkg = do
spec <- getVersionSpecFromQuery
preferMin <- versionPriorityFromQueryIsMin
version <-
getBestVersion pkg spec preferMin
`orThrow` sendResponseStatus status400 (NotFoundE [i|Instructions for #{pkg} satisfying #{spec}|])
(len, src) <- getInstructions pkg version
addHeader "Content-Length" (show len)
respondSource typePlain $ src .| awaitForever sendChunkBS

48
src/Handler/Package/V0/Latest.hs Normal file
View File

@@ -0,0 +1,48 @@
module Handler.Package.V0.Latest where
import Data.Aeson (ToJSON (..), eitherDecode)
import Data.ByteString.Lazy qualified as LBS
import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as HM
import Data.List (lookup)
import Database.Queries (fetchLatestApp)
import Foundation (Handler)
import Lib.Error (S9Error (..))
import Lib.Types.Core (PkgId)
import Lib.Types.Emver (Version)
import Model (Key (..), VersionRecord (..))
import Network.HTTP.Types (status400)
import Startlude (Either (..), Generic, Maybe (..), Show, catMaybes, encodeUtf8, fst, pure, snd, traverse, ($), (.), (<$>))
import Yesod (Entity (..), ToContent (..), ToTypedContent (..), YesodPersist (runDB), YesodRequest (reqGetParams), getRequest, sendResponseStatus)
newtype VersionLatestRes = VersionLatestRes (HashMap PkgId (Maybe Version))
deriving (Show, Generic)
instance ToJSON VersionLatestRes
instance ToContent VersionLatestRes where
toContent = toContent . toJSON
instance ToTypedContent VersionLatestRes where
toTypedContent = toTypedContent . toJSON
-- TODO refactor with conduit
getVersionLatestR :: Handler VersionLatestRes
getVersionLatestR = do
getParameters <- reqGetParams <$> getRequest
case lookup "ids" getParameters of
Nothing -> sendResponseStatus status400 (InvalidParamsE "get:ids" "<MISSING>")
Just packages -> case eitherDecode $ LBS.fromStrict $ encodeUtf8 packages of
Left _ -> sendResponseStatus status400 (InvalidParamsE "get:ids" packages)
Right p -> do
let packageList = (,Nothing) <$> p
found <- runDB $ traverse fetchLatestApp $ fst <$> packageList
pure $
VersionLatestRes $
HM.union
( HM.fromList $
( \v ->
(unPkgRecordKey . entityKey $ fst v, Just $ versionRecordNumber $ entityVal $ snd v)
)
<$> catMaybes found
)
$ HM.fromList packageList

26
src/Handler/Package/V0/License.hs Normal file
View File

@@ -0,0 +1,26 @@
{-# LANGUAGE QuasiQuotes #-}
module Handler.Package.V0.License where
import Conduit (awaitForever, (.|))
import Data.String.Interpolate.IsString (i)
import Foundation (Handler)
import Handler.Util (getVersionSpecFromQuery, orThrow, versionPriorityFromQueryIsMin)
import Lib.Error (S9Error (..))
import Lib.PkgRepository (getBestVersion, getLicense)
import Lib.Types.Core (PkgId)
import Network.HTTP.Types (status400)
import Startlude (show, ($))
import Yesod (TypedContent, addHeader, respondSource, sendChunkBS, sendResponseStatus, typePlain)
getLicenseR :: PkgId -> Handler TypedContent
getLicenseR pkg = do
spec <- getVersionSpecFromQuery
preferMin <- versionPriorityFromQueryIsMin
version <-
getBestVersion pkg spec preferMin
`orThrow` sendResponseStatus status400 (NotFoundE [i|License for #{pkg} satisfying #{spec}|])
(len, src) <- getLicense pkg version
addHeader "Content-Length" (show len)
respondSource typePlain $ src .| awaitForever sendChunkBS

27
src/Handler/Package/V0/Manifest.hs Normal file
View File

@@ -0,0 +1,27 @@
{-# LANGUAGE QuasiQuotes #-}
module Handler.Package.V0.Manifest where
import Conduit (awaitForever, (.|))
import Data.String.Interpolate.IsString (i)
import Foundation (Handler)
import Handler.Util (addPackageHeader, getVersionSpecFromQuery, orThrow, versionPriorityFromQueryIsMin)
import Lib.Error (S9Error (..))
import Lib.PkgRepository (getBestVersion, getManifest)
import Lib.Types.Core (PkgId)
import Network.HTTP.Types (status404)
import Startlude (show, ($))
import Yesod (TypedContent, addHeader, respondSource, sendChunkBS, sendResponseStatus, typeJson)
getAppManifestR :: PkgId -> Handler TypedContent
getAppManifestR pkg = do
versionSpec <- getVersionSpecFromQuery
preferMin <- versionPriorityFromQueryIsMin
version <-
getBestVersion pkg versionSpec preferMin
`orThrow` sendResponseStatus status404 (NotFoundE [i|#{pkg} satisfying #{versionSpec}|])
addPackageHeader pkg version
(len, src) <- getManifest pkg version
addHeader "Content-Length" (show len)
respondSource typeJson $ src .| awaitForever sendChunkBS

39
src/Handler/Package/V0/ReleaseNotes.hs Normal file
View File

@@ -0,0 +1,39 @@
{-# LANGUAGE RecordWildCards #-}
module Handler.Package.V0.ReleaseNotes where
import Data.Aeson (ToJSON (..))
import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as HM
import Database.Queries (fetchAllAppVersions)
import Foundation (Handler, RegistryCtx (..))
import Lib.Types.Core (PkgId)
import Lib.Types.Emver (Version)
import Model (VersionRecord (..))
import Startlude (Down (..), Eq, Show, Text, fst, pure, sortOn, ($), (&&&), (.), (<$>))
import Yesod (ToContent (..), ToTypedContent (..), YesodPersist (runDB), getYesod)
newtype ReleaseNotes = ReleaseNotes {unReleaseNotes :: HashMap Version Text}
deriving (Eq, Show)
instance ToJSON ReleaseNotes where
toJSON ReleaseNotes{..} = toJSON unReleaseNotes
instance ToContent ReleaseNotes where
toContent = toContent . toJSON
instance ToTypedContent ReleaseNotes where
toTypedContent = toTypedContent . toJSON
getReleaseNotesR :: PkgId -> Handler ReleaseNotes
getReleaseNotesR pkg = do
appConnPool <- appConnPool <$> getYesod
versionRecords <- runDB $ fetchAllAppVersions appConnPool pkg
pure $ constructReleaseNotesApiRes versionRecords
where
constructReleaseNotesApiRes :: [VersionRecord] -> ReleaseNotes
constructReleaseNotesApiRes vers = do
ReleaseNotes $
HM.fromList $
sortOn (Down . fst) $
(versionRecordNumber &&& versionRecordReleaseNotes)
<$> vers

49
src/Handler/Package/V0/S9PK.hs Normal file
View File

@@ -0,0 +1,49 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
module Handler.Package.V0.S9PK where
import Data.String.Interpolate.IsString (i)
import Data.Text qualified as T
import Database.Queries (createMetric, fetchAppVersion)
import Foundation (Handler)
import GHC.Show (show)
import Handler.Util (addPackageHeader, getVersionSpecFromQuery, orThrow, versionPriorityFromQueryIsMin)
import Lib.Error (S9Error (..))
import Lib.PkgRepository (getBestVersion, getPackage)
import Lib.Types.Core (PkgId (..), S9PK)
import Lib.Types.Emver (Version (..))
import Network.HTTP.Types (status404)
import Startlude (Maybe (..), pure, void, ($), (.), (>>=))
import System.FilePath (takeBaseName)
import Yesod (Content (..), TypedContent, YesodPersist (runDB), notFound, respond, sendResponseStatus, typeOctet)
import Yesod.Core (logError)
getAppR :: S9PK -> Handler TypedContent
getAppR file = do
let pkg = PkgId . T.pack $ takeBaseName (show file)
versionSpec <- getVersionSpecFromQuery
preferMin <- versionPriorityFromQueryIsMin
version <-
getBestVersion pkg versionSpec preferMin
`orThrow` sendResponseStatus status404 (NotFoundE [i|#{pkg} satisfying #{versionSpec}|])
addPackageHeader pkg version
void $ recordMetrics pkg version
pkgPath <-
getPackage pkg version >>= \case
Nothing -> sendResponseStatus status404 (NotFoundE [i|#{pkg}@#{version}|])
Just a -> pure a
respond typeOctet $ ContentFile pkgPath Nothing
recordMetrics :: PkgId -> Version -> Handler ()
recordMetrics pkg appVersion = do
existingVersion <- runDB $ fetchAppVersion pkg appVersion
case existingVersion of
Nothing ->
do
$logError [i|#{pkg}@#{appVersion} not found in database|]
notFound
Just _ -> runDB $ createMetric pkg appVersion

46
src/Handler/Package/V0/Version.hs Normal file
View File

@@ -0,0 +1,46 @@
{-# LANGUAGE QuasiQuotes #-}
module Handler.Package.V0.Version where
import Data.Aeson (ToJSON, object, (.=))
import Data.String.Interpolate.IsString (i)
import Foundation (Handler)
import Handler.Util (
getVersionSpecFromQuery,
orThrow,
versionPriorityFromQueryIsMin,
)
import Lib.Error (S9Error (..))
import Lib.PkgRepository (getBestVersion)
import Lib.Types.Core (PkgId)
import Lib.Types.Emver (Version (..))
import Network.HTTP.Types (status404)
import Startlude (Eq, Maybe, Show, (.), (<$>))
import Yesod (ToContent (..), ToTypedContent, sendResponseStatus)
import Yesod.Core (ToJSON (..), ToTypedContent (..))
newtype AppVersionRes = AppVersionRes
{ appVersionVersion :: Version
}
deriving (Eq, Show)
instance ToJSON AppVersionRes where
toJSON AppVersionRes{appVersionVersion} = object ["version" .= appVersionVersion]
instance ToContent AppVersionRes where
toContent = toContent . toJSON
instance ToTypedContent AppVersionRes where
toTypedContent = toTypedContent . toJSON
instance ToContent (Maybe AppVersionRes) where
toContent = toContent . toJSON
instance ToTypedContent (Maybe AppVersionRes) where
toTypedContent = toTypedContent . toJSON
getPkgVersionR :: PkgId -> Handler AppVersionRes
getPkgVersionR pkg = do
spec <- getVersionSpecFromQuery
preferMin <- versionPriorityFromQueryIsMin
AppVersionRes <$> getBestVersion pkg spec preferMin
`orThrow` sendResponseStatus
status404
(NotFoundE [i|Version for #{pkg} satisfying #{spec}|])

36
src/Handler/Types/Api.hs Normal file
View File

@@ -0,0 +1,36 @@
module Handler.Types.Api where
import GHC.Read (Read (..))
import GHC.Show (show)
import Startlude (
Eq,
Maybe (..),
Ord,
Show,
)
import Yesod (PathPiece (..))
data ApiVersion
= V0
| V1
deriving (Eq, Ord)
instance Show ApiVersion where
show V0 = "v0"
show V1 = "v1"
instance Read ApiVersion where
readsPrec _ "v0" = [(V0, "")]
readsPrec _ "v1" = [(V1, "")]
readsPrec _ _ = []
instance PathPiece ApiVersion where
toPathPiece V0 = "v0"
toPathPiece V1 = "v1"
fromPathPiece "v0" = Just V0
fromPathPiece "v1" = Just V1
fromPathPiece _ = Nothing

163
src/Handler/Types/Marketplace.hs
View File

@@ -1,163 +0,0 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DeriveGeneric #-}
module Handler.Types.Marketplace where
import Data.Aeson ( (.:)
, FromJSON(parseJSON)
, KeyValue((.=))
, ToJSON(toJSON)
, Value(String)
, object
, withObject
)
import qualified Data.HashMap.Internal.Strict as HM
import Lib.Types.AppIndex ( PkgId )
import Lib.Types.Emver ( Version
, VersionRange
)
import Model ( Category
, PkgDependency
, PkgRecord
, VersionRecord
)
import Startlude ( ($)
, (.)
, Applicative(pure)
, Eq
, Generic
, Int
, Maybe
, Read
, Show
, Text
)
import Yesod ( Entity
, ToContent(..)
, ToTypedContent(..)
)
type URL = Text
type CategoryTitle = Text
data InfoRes = InfoRes
{ name :: !Text
, categories :: ![CategoryTitle]
}
deriving (Show, Generic)
instance ToJSON InfoRes
instance ToContent InfoRes where
toContent = toContent . toJSON
instance ToTypedContent InfoRes where
toTypedContent = toTypedContent . toJSON
data PackageRes = PackageRes
{ packageResIcon :: !URL
, packageResManifest :: !Data.Aeson.Value -- PackageManifest
, packageResCategories :: ![CategoryTitle]
, packageResInstructions :: !URL
, packageResLicense :: !URL
, packageResVersions :: ![Version]
, packageResDependencies :: !(HM.HashMap PkgId DependencyRes)
}
deriving (Show, Generic)
newtype ReleaseNotes = ReleaseNotes { unReleaseNotes :: HM.HashMap Version Text }
deriving (Eq, Show)
instance ToJSON ReleaseNotes where
toJSON ReleaseNotes {..} = object [ t .= v | (k, v) <- HM.toList unReleaseNotes, let (String t) = toJSON k ]
instance ToContent ReleaseNotes where
toContent = toContent . toJSON
instance ToTypedContent ReleaseNotes where
toTypedContent = toTypedContent . toJSON
instance ToJSON PackageRes where
toJSON PackageRes {..} = object
[ "icon" .= packageResIcon
, "license" .= packageResLicense
, "instructions" .= packageResInstructions
, "manifest" .= packageResManifest
, "categories" .= packageResCategories
, "versions" .= packageResVersions
, "dependency-metadata" .= packageResDependencies
]
instance FromJSON PackageRes where
parseJSON = withObject "PackageRes" $ \o -> do
packageResIcon <- o .: "icon"
packageResLicense <- o .: "license"
packageResInstructions <- o .: "instructions"
packageResManifest <- o .: "manifest"
packageResCategories <- o .: "categories"
packageResVersions <- o .: "versions"
packageResDependencies <- o .: "dependency-metadata"
pure PackageRes { .. }
data DependencyRes = DependencyRes
{ dependencyResTitle :: !Text
, dependencyResIcon :: !Text
}
deriving (Eq, Show)
instance ToJSON DependencyRes where
toJSON DependencyRes {..} = object ["icon" .= dependencyResIcon, "title" .= dependencyResTitle]
instance FromJSON DependencyRes where
parseJSON = withObject "DependencyRes" $ \o -> do
dependencyResIcon <- o .: "icon"
dependencyResTitle <- o .: "title"
pure DependencyRes { .. }
newtype PackageListRes = PackageListRes [PackageRes]
deriving (Generic)
instance ToJSON PackageListRes
instance ToContent PackageListRes where
toContent = toContent . toJSON
instance ToTypedContent PackageListRes where
toTypedContent = toTypedContent . toJSON
newtype VersionLatestRes = VersionLatestRes (HM.HashMap PkgId (Maybe Version))
deriving (Show, Generic)
instance ToJSON VersionLatestRes
instance ToContent VersionLatestRes where
toContent = toContent . toJSON
instance ToTypedContent VersionLatestRes where
toTypedContent = toTypedContent . toJSON
data OrderArrangement = ASC | DESC
deriving (Eq, Show, Read)
data PackageListDefaults = PackageListDefaults
{ packageListOrder :: !OrderArrangement
, packageListPageLimit :: !Int -- the number of items per page
, packageListPageNumber :: !Int -- the page you are on
, packageListCategory :: !(Maybe CategoryTitle)
, packageListQuery :: !Text
}
deriving (Eq, Show, Read)
data EosRes = EosRes
{ eosResVersion :: !Version
, eosResHeadline :: !Text
, eosResReleaseNotes :: !ReleaseNotes
}
deriving (Eq, Show, Generic)
instance ToJSON EosRes where
toJSON EosRes {..} =
object ["version" .= eosResVersion, "headline" .= eosResHeadline, "release-notes" .= eosResReleaseNotes]
instance ToContent EosRes where
toContent = toContent . toJSON
instance ToTypedContent EosRes where
toTypedContent = toTypedContent . toJSON
data PackageReq = PackageReq
{ packageReqId :: !PkgId
, packageReqVersion :: !VersionRange
}
deriving Show
instance FromJSON PackageReq where
parseJSON = withObject "package version" $ \o -> do
packageReqId <- o .: "id"
packageReqVersion <- o .: "version"
pure PackageReq { .. }
data PackageMetadata = PackageMetadata
{ packageMetadataPkgId :: !PkgId
, packageMetadataPkgVersionRecords :: ![Entity VersionRecord]
, packageMetadataPkgCategories :: ![Entity Category]
, packageMetadataPkgVersion :: !Version
}
deriving (Eq, Show)
data PackageDependencyMetadata = PackageDependencyMetadata
{ packageDependencyMetadataPkgDependencyRecord :: !(Entity PkgDependency)
, packageDependencyMetadataDepPkgRecord :: !(Entity PkgRecord)
, packageDependencyMetadataDepVersions :: ![Entity VersionRecord]
}
deriving (Eq, Show)

37
src/Handler/Types/Status.hs
View File

@@ -1,37 +0,0 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Use newtype instead of data" #-}
module Handler.Types.Status where
import Startlude ( (.)
, Eq
, Maybe
, Show
)
import Data.Aeson ( KeyValue((.=))
, ToJSON(toJSON)
, object
)
import Yesod.Core.Content ( ToContent(..)
, ToTypedContent(..)
)
import Lib.Types.Emver ( Version )
import Orphans.Emver ( )
newtype AppVersionRes = AppVersionRes
{ appVersionVersion :: Version
}
deriving (Eq, Show)
instance ToJSON AppVersionRes where
toJSON AppVersionRes { appVersionVersion } = object ["version" .= appVersionVersion]
instance ToContent AppVersionRes where
toContent = toContent . toJSON
instance ToTypedContent AppVersionRes where
toTypedContent = toTypedContent . toJSON
instance ToContent (Maybe AppVersionRes) where
toContent = toContent . toJSON
instance ToTypedContent (Maybe AppVersionRes) where
toTypedContent = toTypedContent . toJSON

103
src/Handler/Util.hs Normal file
View File

@@ -0,0 +1,103 @@
{-# LANGUAGE QuasiQuotes #-}
module Handler.Util where
import Control.Monad.Reader.Has (
Has,
MonadReader,
)
import Data.Attoparsec.Text (Parser, parseOnly)
import Data.String.Interpolate.IsString (i)
import Data.Text qualified as T
import Data.Text.Lazy qualified as TL
import Data.Text.Lazy.Builder qualified as TB
import Lib.PkgRepository (PkgRepo, getHash)
import Lib.Types.Core (PkgId)
import Lib.Types.Emver (
Version,
VersionRange,
)
import Network.HTTP.Types (
Status,
status400,
)
import Startlude (
Bool (..),
Either (..),
Foldable (foldMap),
Maybe (..),
Monoid (..),
Semigroup ((<>)),
Text,
decodeUtf8,
fromMaybe,
fst,
isSpace,
not,
pure,
readMaybe,
($),
(.),
(<$>),
(>>=),
)
import UnliftIO (MonadUnliftIO)
import Yesod (
MonadHandler,
RenderRoute (..),
TypedContent (..),
lookupGetParam,
sendResponseStatus,
toContent,
typePlain,
)
import Yesod.Core (addHeader)
orThrow :: MonadHandler m => m (Maybe a) -> m a -> m a
orThrow action other =
action >>= \case
Nothing -> other
Just x -> pure x
sendResponseText :: MonadHandler m => Status -> Text -> m a
sendResponseText s = sendResponseStatus s . TypedContent typePlain . toContent
getVersionSpecFromQuery :: MonadHandler m => m VersionRange
getVersionSpecFromQuery = do
specString <- T.filter (not . isSpace) . fromMaybe "*" <$> lookupGetParam "spec"
case readMaybe specString of
Nothing -> sendResponseStatus status400 ("Invalid App Version Specification" :: Text)
Just t -> pure t
versionPriorityFromQueryIsMin :: MonadHandler m => m Bool
versionPriorityFromQueryIsMin = do
priorityString <- lookupGetParam "version-priority"
case priorityString of
Nothing -> pure False
(Just "max") -> pure False
(Just "min") -> pure True
(Just t) -> sendResponseStatus status400 ("Invalid Version Priority Specification: " <> t)
addPackageHeader :: (MonadUnliftIO m, MonadHandler m, MonadReader r m, Has PkgRepo r) => PkgId -> Version -> m ()
addPackageHeader pkg version = do
packageHash <- getHash pkg version
addHeader "X-S9PK-HASH" $ decodeUtf8 packageHash
basicRender :: RenderRoute a => Route a -> Text
basicRender = TL.toStrict . TB.toLazyText . foldMap (mappend (TB.singleton '/') . TB.fromText) . fst . renderRoute
queryParamAs :: MonadHandler m => Text -> Parser a -> m (Maybe a)
queryParamAs k p =
lookupGetParam k >>= \case
Nothing -> pure Nothing
Just x -> case parseOnly p x of
Left e ->
sendResponseText status400 [i|Invalid Request! The query parameter '#{k}' failed to parse: #{e}|]
Right a -> pure (Just a)

32
src/Handler/Version.hs
View File

@@ -1,32 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
module Handler.Version where
import Startlude ( (<$>) )
import Yesod.Core ( sendResponseStatus )
import Data.String.Interpolate.IsString
( i )
import Foundation ( Handler )
import Handler.Types.Status ( AppVersionRes(AppVersionRes) )
import Lib.Error ( S9Error(NotFoundE) )
import Lib.PkgRepository ( getBestVersion )
import Lib.Types.AppIndex ( PkgId )
import Network.HTTP.Types.Status ( status404 )
import Util.Shared ( getVersionSpecFromQuery
, orThrow
, versionPriorityFromQueryIsMin
)
getPkgVersionR :: PkgId -> Handler AppVersionRes
getPkgVersionR pkg = do
spec <- getVersionSpecFromQuery
preferMin <- versionPriorityFromQueryIsMin
AppVersionRes <$> getBestVersion pkg spec preferMin `orThrow` sendResponseStatus
status404
(NotFoundE [i|Version for #{pkg} satisfying #{spec}|])

222
src/Lib/External/AppMgr.hs vendored
View File

@@ -1,158 +1,148 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
module Lib.External.AppMgr where module Lib.External.AppMgr (
sourceManifest,
getPackageHash,
sourceInstructions,
sourceLicense,
sourceIcon,
) where
import Startlude ( ($) import Startlude (
, (&&) Applicative (pure, (*>)),
, (<$>) ByteString,
, Applicative((*>), pure) Eq ((==)),
, ByteString FilePath,
, Eq((==)) String,
, ExitCode id,
, FilePath stderr,
, Monad throwIO,
, MonadIO(..) ($),
, Monoid (&&),
, String )
, atomically
, id
, liftA3
, stderr
, throwIO
)
import qualified Data.ByteString.Lazy as LBS import Data.ByteString.Lazy qualified as LBS
import Data.String.Interpolate.IsString import Data.String.Interpolate.IsString (
( i ) i,
import System.Process.Typed ( ExitCodeException(eceExitCode) )
, Process import System.Process.Typed (
, ProcessConfig ExitCodeException (eceExitCode),
, byteStringInput Process,
, byteStringOutput ProcessConfig,
, getStderr byteStringInput,
, getStdout getStdout,
, proc proc,
, setEnvInherit setEnvInherit,
, setStderr setStderr,
, setStdin setStdin,
, setStdout setStdout,
, startProcess startProcess,
, stopProcess stopProcess,
, useHandleOpen useHandleOpen,
, waitExitCodeSTM )
, withProcessWait
)
import Conduit ( (.|) import Conduit (
, ConduitT ConduitT,
, runConduit runConduit,
) (.|),
import Control.Monad.Logger ( MonadLoggerIO )
, logErrorSH import Control.Monad.Logger (
) MonadLoggerIO,
import qualified Data.Conduit.List as CL logErrorSH,
import Data.Conduit.Process.Typed ( createSource ) )
import GHC.IO.Exception ( IOErrorType(NoSuchThing) import Data.Conduit.List qualified as CL
, IOException(ioe_description, ioe_type) import Data.Conduit.Process.Typed (createSource)
) import GHC.IO.Exception (
import Lib.Error ( S9Error(AppMgrE) ) IOErrorType (NoSuchThing),
import System.FilePath ( (</>) ) IOException (ioe_description, ioe_type),
import UnliftIO ( MonadUnliftIO )
, bracket import Lib.Error (S9Error (AppMgrE))
, catch import System.FilePath ((</>))
) import UnliftIO (
MonadUnliftIO,
bracket,
catch,
)
readProcessWithExitCode' :: MonadIO m => String -> [String] -> ByteString -> m (ExitCode, ByteString, ByteString)
readProcessWithExitCode' a b c = liftIO $ do
let pc =
setStdin (byteStringInput $ LBS.fromStrict c)
$ setStderr byteStringOutput
$ setEnvInherit
$ setStdout byteStringOutput
$ System.Process.Typed.proc a b
withProcessWait pc $ \process -> atomically $ liftA3 (,,)
(waitExitCodeSTM process)
(LBS.toStrict <$> getStdout process)
(LBS.toStrict <$> getStderr process)
readProcessInheritStderr :: forall m a readProcessInheritStderr ::
. MonadUnliftIO m forall m a.
=> String MonadUnliftIO m =>
-> [String] String ->
-> ByteString [String] ->
-> (ConduitT () ByteString m () -> m a) -- this is because we can't clean up the process in the unCPS'ed version of this ByteString ->
-> m a (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 readProcessInheritStderr a b c sink = do
let pc = let pc =
setStdin (byteStringInput $ LBS.fromStrict c) setStdin (byteStringInput $ LBS.fromStrict c) $
$ setEnvInherit setEnvInherit $
$ setStderr (useHandleOpen stderr) setStderr (useHandleOpen stderr) $
$ setStdout createSource setStdout createSource $
$ System.Process.Typed.proc a b System.Process.Typed.proc a b
withProcessTerm' pc $ \p -> sink (getStdout p) withProcessTerm' pc $ \p -> sink (getStdout p)
where where
-- We need this to deal with https://github.com/haskell/process/issues/215 -- We need this to deal with https://github.com/haskell/process/issues/215
withProcessTerm' :: (MonadUnliftIO m) withProcessTerm' ::
=> ProcessConfig stdin stdout stderr (MonadUnliftIO m) =>
-> (Process stdin stdout stderr -> m a) ProcessConfig stdin stdout stderr ->
-> m a (Process stdin stdout stderr -> m a) ->
m a
withProcessTerm' cfg = bracket (startProcess cfg) $ \p -> do withProcessTerm' cfg = bracket (startProcess cfg) $ \p -> do
stopProcess p stopProcess p
`catch` (\e -> if ioe_type e == NoSuchThing && ioe_description e == "No child processes" `catch` ( \e ->
then pure () if ioe_type e == NoSuchThing && ioe_description e == "No child processes"
else throwIO e then pure ()
else throwIO e
) )
sourceManifest :: (MonadUnliftIO m, MonadLoggerIO m)
=> FilePath sourceManifest ::
-> FilePath (MonadUnliftIO m, MonadLoggerIO m) =>
-> (ConduitT () ByteString m () -> m r) FilePath ->
-> m r FilePath ->
(ConduitT () ByteString m () -> m r) ->
m r
sourceManifest appmgrPath pkgFile sink = do sourceManifest appmgrPath pkgFile sink = do
let appmgr = readProcessInheritStderr (appmgrPath </> "embassy-sdk") ["inspect", "manifest", pkgFile] "" let appmgr = readProcessInheritStderr (appmgrPath </> "embassy-sdk") ["inspect", "manifest", pkgFile] ""
appmgr sink `catch` \ece -> appmgr sink `catch` \ece ->
$logErrorSH ece *> throwIO (AppMgrE [i|embassy-sdk inspect manifest #{pkgFile}|] (eceExitCode ece)) $logErrorSH ece *> throwIO (AppMgrE [i|embassy-sdk inspect manifest #{pkgFile}|] (eceExitCode ece))
sourceIcon :: (MonadUnliftIO m, MonadLoggerIO m) => FilePath -> FilePath -> (ConduitT () ByteString m () -> m r) -> m r sourceIcon :: (MonadUnliftIO m, MonadLoggerIO m) => FilePath -> FilePath -> (ConduitT () ByteString m () -> m r) -> m r
sourceIcon appmgrPath pkgFile sink = do sourceIcon appmgrPath pkgFile sink = do
let appmgr = readProcessInheritStderr (appmgrPath </> "embassy-sdk") ["inspect", "icon", pkgFile] "" let appmgr = readProcessInheritStderr (appmgrPath </> "embassy-sdk") ["inspect", "icon", pkgFile] ""
appmgr sink `catch` \ece -> appmgr sink `catch` \ece ->
$logErrorSH ece *> throwIO (AppMgrE [i|embassy-sdk inspect icon #{pkgFile}|] (eceExitCode ece)) $logErrorSH ece *> throwIO (AppMgrE [i|embassy-sdk inspect icon #{pkgFile}|] (eceExitCode ece))
getPackageHash :: (MonadUnliftIO m, MonadLoggerIO m) => FilePath -> FilePath -> m ByteString getPackageHash :: (MonadUnliftIO m, MonadLoggerIO m) => FilePath -> FilePath -> m ByteString
getPackageHash appmgrPath pkgFile = do getPackageHash appmgrPath pkgFile = do
let appmgr = readProcessInheritStderr (appmgrPath </> "embassy-sdk") ["inspect", "hash", pkgFile] "" let appmgr = readProcessInheritStderr (appmgrPath </> "embassy-sdk") ["inspect", "hash", pkgFile] ""
appmgr (\bsSource -> runConduit $ bsSource .| CL.foldMap id) `catch` \ece -> appmgr (\bsSource -> runConduit $ bsSource .| CL.foldMap id) `catch` \ece ->
$logErrorSH ece *> throwIO (AppMgrE [i|embassy-sdk inspect hash #{pkgFile}|] (eceExitCode ece)) $logErrorSH ece *> throwIO (AppMgrE [i|embassy-sdk inspect hash #{pkgFile}|] (eceExitCode ece))
sourceInstructions :: (MonadUnliftIO m, MonadLoggerIO m)
=> FilePath sourceInstructions ::
-> FilePath (MonadUnliftIO m, MonadLoggerIO m) =>
-> (ConduitT () ByteString m () -> m r) FilePath ->
-> m r FilePath ->
(ConduitT () ByteString m () -> m r) ->
m r
sourceInstructions appmgrPath pkgFile sink = do sourceInstructions appmgrPath pkgFile sink = do
let appmgr = readProcessInheritStderr (appmgrPath </> "embassy-sdk") ["inspect", "instructions", pkgFile] "" let appmgr = readProcessInheritStderr (appmgrPath </> "embassy-sdk") ["inspect", "instructions", pkgFile] ""
appmgr sink `catch` \ece -> appmgr sink `catch` \ece ->
$logErrorSH ece *> throwIO (AppMgrE [i|embassy-sdk inspect instructions #{pkgFile}|] (eceExitCode ece)) $logErrorSH ece *> throwIO (AppMgrE [i|embassy-sdk inspect instructions #{pkgFile}|] (eceExitCode ece))
sourceLicense :: (MonadUnliftIO m, MonadLoggerIO m)
=> FilePath sourceLicense ::
-> FilePath (MonadUnliftIO m, MonadLoggerIO m) =>
-> (ConduitT () ByteString m () -> m r) FilePath ->
-> m r FilePath ->
(ConduitT () ByteString m () -> m r) ->
m r
sourceLicense appmgrPath pkgFile sink = do sourceLicense appmgrPath pkgFile sink = do
let appmgr = readProcessInheritStderr (appmgrPath </> "embassy-sdk") ["inspect", "license", pkgFile] "" let appmgr = readProcessInheritStderr (appmgrPath </> "embassy-sdk") ["inspect", "license", pkgFile] ""
appmgr sink `catch` \ece -> appmgr sink `catch` \ece ->
$logErrorSH ece *> throwIO (AppMgrE [i|embassy-sdk inspect license #{pkgFile}|] (eceExitCode ece)) $logErrorSH ece *> throwIO (AppMgrE [i|embassy-sdk inspect license #{pkgFile}|] (eceExitCode ece))
sinkMem :: (Monad m, Monoid a) => ConduitT () a m () -> m a
sinkMem c = runConduit $ c .| CL.foldMap id

473
src/Lib/PkgRepository.hs
View File

@@ -1,180 +1,199 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-} {-# OPTIONS_GHC -Wno-name-shadowing #-}
{-# LANGUAGE GADTs #-}
module Lib.PkgRepository where module Lib.PkgRepository where
import Conduit ( (.|) import Conduit (
, ConduitT ConduitT,
, MonadResource MonadResource,
, runConduit runConduit,
, runResourceT runResourceT,
, sinkFileCautious sinkFileCautious,
, sourceFile sourceFile,
) (.|),
import Control.Monad.Logger ( MonadLogger )
, MonadLoggerIO import Control.Monad.Logger (
, logError MonadLogger,
, logInfo MonadLoggerIO,
, logWarn logError,
) logInfo,
import Control.Monad.Reader.Has ( Has logWarn,
, ask )
, asks import Control.Monad.Reader.Has (
) Has,
import Crypto.Hash ( SHA256 ) ask,
import Crypto.Hash.Conduit ( hashFile ) asks,
import Data.Aeson ( eitherDecodeFileStrict' ) )
import qualified Data.Attoparsec.Text as Atto import Crypto.Hash (SHA256)
import Data.Attoparsec.Text ( parseOnly ) import Crypto.Hash.Conduit (hashFile)
import Data.ByteArray.Encoding ( Base(Base16) import Data.Aeson (eitherDecodeFileStrict')
, convertToBase import Data.Attoparsec.Text (parseOnly)
) import Data.Attoparsec.Text qualified as Atto
import Data.ByteString ( readFile import Data.ByteArray.Encoding (
, writeFile Base (Base16),
) convertToBase,
import qualified Data.HashMap.Strict as HM )
import Data.String.Interpolate.IsString import Data.ByteString (
( i ) readFile,
import qualified Data.Text as T writeFile,
import Data.Time ( getCurrentTime ) )
import Database.Esqueleto.Experimental import Data.HashMap.Strict qualified as HM
( ConnectionPool import Data.String.Interpolate.IsString (
, insertUnique i,
, runSqlPool )
) import Data.Text qualified as T
import Database.Persist ( (=.) import Data.Time (getCurrentTime)
, insertKey import Database.Esqueleto.Experimental (
, update ConnectionPool,
, upsert insertUnique,
) runSqlPool,
import Database.Persist.Sql ( SqlPersistT )
, runSqlPoolNoTransaction import Database.Persist (
) insertKey,
import Database.PostgreSQL.Simple ( SqlError(sqlState) ) update,
import Lib.Error ( S9Error(NotFoundE) ) upsert,
import qualified Lib.External.AppMgr as AppMgr (=.),
import Lib.Types.AppIndex ( PackageDependency(..) )
, PackageManifest(..) import Database.Persist.Sql (
, PkgId(..) SqlPersistT,
, packageDependencyVersion runSqlPoolNoTransaction,
, packageManifestDependencies )
) import Database.PostgreSQL.Simple (SqlError (sqlState))
import Lib.Types.Emver ( Version import Lib.Error (S9Error (NotFoundE))
, VersionRange import Lib.External.AppMgr qualified as AppMgr
, parseVersion import Lib.Types.Core (
, satisfies PkgId (..),
) )
import Model ( EntityField(EosHashHash, PkgRecordUpdatedAt) import Lib.Types.Emver (
, EosHash(EosHash) Version,
, Key(PkgRecordKey) VersionRange,
, PkgDependency(PkgDependency) parseVersion,
, PkgRecord(PkgRecord) satisfies,
) )
import Startlude ( ($) import Lib.Types.Manifest (PackageDependency (..), PackageManifest (..))
, (&&) import Model (
, (.) EntityField (EosHashHash, PkgRecordUpdatedAt),
, (/=) EosHash (EosHash),
, (<$>) Key (PkgRecordKey),
, Bool(..) PkgDependency (PkgDependency),
, ByteString PkgRecord (PkgRecord),
, Down(..) )
, Either(..) import Startlude (
, Eq((==)) Bool (..),
, Exception ByteString,
, FilePath Down (..),
, IO Either (..),
, Integer Eq ((==)),
, Maybe(..) Exception,
, MonadIO(liftIO) FilePath,
, MonadReader IO,
, Ord(compare) Integer,
, Show Maybe (..),
, SomeException(..) MonadIO (liftIO),
, decodeUtf8 MonadReader,
, filter Ord (compare),
, find Show,
, first SomeException (..),
, flip decodeUtf8,
, for_ filter,
, fst find,
, headMay first,
, not flip,
, on for_,
, partitionEithers fst,
, pure headMay,
, show not,
, snd on,
, sortBy partitionEithers,
, throwIO pure,
, toS show,
, void snd,
) sortBy,
import System.FSNotify ( ActionPredicate throwIO,
, Event(..) toS,
, eventPath void,
, watchTree ($),
, withManager (&&),
) (.),
import System.FilePath ( (<.>) (/=),
, (</>) (<$>),
, takeBaseName )
, takeDirectory import System.FSNotify (
, takeExtension ActionPredicate,
, takeFileName Event (..),
) eventPath,
import UnliftIO ( MonadUnliftIO watchTree,
, askRunInIO withManager,
, async )
, catch import System.FilePath (
, mapConcurrently_ takeBaseName,
, newEmptyMVar takeDirectory,
, takeMVar takeExtension,
, tryPutMVar takeFileName,
, wait (<.>),
) (</>),
import UnliftIO.Concurrent ( forkIO ) )
import UnliftIO.Directory ( doesDirectoryExist import UnliftIO (
, doesPathExist MonadUnliftIO,
, getFileSize askRunInIO,
, listDirectory async,
, removeFile catch,
, renameFile mapConcurrently_,
) newEmptyMVar,
import UnliftIO.Exception ( handle ) takeMVar,
import Yesod.Core.Content ( typeGif tryPutMVar,
, typeJpeg wait,
, typePlain )
, typePng import UnliftIO.Concurrent (forkIO)
, typeSvg import UnliftIO.Directory (
) doesDirectoryExist,
import Yesod.Core.Types ( ContentType ) doesPathExist,
getFileSize,
listDirectory,
removeFile,
renameFile,
)
import UnliftIO.Exception (handle)
import Yesod.Core.Content (
typeGif,
typeJpeg,
typePlain,
typePng,
typeSvg,
)
import Yesod.Core.Types (ContentType)
newtype ManifestParseException = ManifestParseException FilePath newtype ManifestParseException = ManifestParseException FilePath
deriving Show deriving (Show)
instance Exception ManifestParseException instance Exception ManifestParseException
data PkgRepo = PkgRepo data PkgRepo = PkgRepo
{ pkgRepoFileRoot :: !FilePath { pkgRepoFileRoot :: !FilePath
, pkgRepoAppMgrBin :: !FilePath , pkgRepoAppMgrBin :: !FilePath
} }
newtype EosRepo = EosRepo newtype EosRepo = EosRepo
{ eosRepoFileRoot :: FilePath { eosRepoFileRoot :: FilePath
} }
getPackages :: (MonadIO m, MonadReader r m, Has PkgRepo r) => m [PkgId] getPackages :: (MonadIO m, MonadReader r m, Has PkgRepo r) => m [PkgId]
getPackages = do getPackages = do
root <- asks pkgRepoFileRoot root <- asks pkgRepoFileRoot
paths <- listDirectory root paths <- listDirectory root
pure $ PkgId . toS <$> paths pure $ PkgId . toS <$> paths
getVersionsFor :: (MonadIO m, MonadReader r m, Has PkgRepo r, MonadLogger m) => PkgId -> m [Version] getVersionsFor :: (MonadIO m, MonadReader r m, Has PkgRepo r, MonadLogger m) => PkgId -> m [Version]
getVersionsFor pkg = do getVersionsFor pkg = do
root <- asks pkgRepoFileRoot root <- asks pkgRepoFileRoot
@@ -188,52 +207,66 @@ getVersionsFor pkg = do
pure successes pure successes
else pure [] else pure []
getViableVersions :: (MonadIO m, MonadReader r m, Has PkgRepo r, MonadLogger m) => PkgId -> VersionRange -> m [Version] getViableVersions :: (MonadIO m, MonadReader r m, Has PkgRepo r, MonadLogger m) => PkgId -> VersionRange -> m [Version]
getViableVersions pkg spec = filter (`satisfies` spec) <$> getVersionsFor pkg getViableVersions pkg spec = filter (`satisfies` spec) <$> getVersionsFor pkg
getBestVersion :: (MonadIO m, MonadReader r m, Has PkgRepo r, MonadLogger m)
=> PkgId getBestVersion ::
-> VersionRange (MonadIO m, MonadReader r m, Has PkgRepo r, MonadLogger m) =>
-> Bool PkgId ->
-> m (Maybe Version) VersionRange ->
Bool ->
m (Maybe Version)
getBestVersion pkg spec preferMin = headMay . sortBy comparator <$> getViableVersions pkg spec getBestVersion pkg spec preferMin = headMay . sortBy comparator <$> getViableVersions pkg spec
where comparator = if preferMin then compare else compare `on` Down where
comparator = if preferMin then compare else compare `on` Down
loadPkgDependencies :: MonadUnliftIO m => ConnectionPool -> PackageManifest -> m () loadPkgDependencies :: MonadUnliftIO m => ConnectionPool -> PackageManifest -> m ()
loadPkgDependencies appConnPool manifest = do loadPkgDependencies appConnPool manifest = do
let pkgId = packageManifestId manifest let pkgId = packageManifestId manifest
let pkgVersion = packageManifestVersion manifest let pkgVersion = packageManifestVersion manifest
let deps = packageManifestDependencies manifest let deps = packageManifestDependencies manifest
time <- liftIO getCurrentTime time <- liftIO getCurrentTime
_ <- runWith appConnPool $ insertKey (PkgRecordKey pkgId) (PkgRecord time Nothing) `catch` \(e :: SqlError) -> _ <-
-- 23505 is "already exists" runWith appConnPool $
if sqlState e == "23505" then update (PkgRecordKey pkgId) [PkgRecordUpdatedAt =. Just time] else throwIO e insertKey (PkgRecordKey pkgId) (PkgRecord time Nothing) `catch` \(e :: SqlError) ->
-- 23505 is "already exists"
if sqlState e == "23505" then update (PkgRecordKey pkgId) [PkgRecordUpdatedAt =. Just time] else throwIO e
let deps' = first PkgRecordKey <$> HM.toList deps let deps' = first PkgRecordKey <$> HM.toList deps
for_ for_
deps' deps'
(\d -> flip runSqlPool appConnPool $ do ( \d -> flip runSqlPool appConnPool $ do
_ <- runWith appConnPool $ insertKey (fst d) (PkgRecord time Nothing) `catch` \(e :: SqlError) -> _ <-
-- 23505 is "already exists" runWith appConnPool $
if sqlState e == "23505" then update (fst d) [PkgRecordUpdatedAt =. Just time] else throwIO e insertKey (fst d) (PkgRecord time Nothing) `catch` \(e :: SqlError) ->
insertUnique -- 23505 is "already exists"
$ PkgDependency time (PkgRecordKey pkgId) pkgVersion (fst d) (packageDependencyVersion . snd $ d) if sqlState e == "23505" then update (fst d) [PkgRecordUpdatedAt =. Just time] else throwIO e
insertUnique $
PkgDependency time (PkgRecordKey pkgId) pkgVersion (fst d) (packageDependencyVersion . snd $ d)
) )
where where
runWith :: MonadUnliftIO m => ConnectionPool -> SqlPersistT m a -> m a runWith :: MonadUnliftIO m => ConnectionPool -> SqlPersistT m a -> m a
runWith pool action = runSqlPoolNoTransaction action pool Nothing runWith pool action = runSqlPoolNoTransaction action pool Nothing
-- extract all package assets into their own respective files -- extract all package assets into their own respective files
extractPkg :: (MonadUnliftIO m, MonadReader r m, Has PkgRepo r, MonadLoggerIO m) => ConnectionPool -> FilePath -> m () extractPkg :: (MonadUnliftIO m, MonadReader r m, Has PkgRepo r, MonadLoggerIO m) => ConnectionPool -> FilePath -> m ()
extractPkg pool fp = handle @_ @SomeException cleanup $ do extractPkg pool fp = handle @_ @SomeException cleanup $ do
$logInfo [i|Extracting package: #{fp}|] $logInfo [i|Extracting package: #{fp}|]
PkgRepo { pkgRepoAppMgrBin = appmgr } <- ask PkgRepo{pkgRepoAppMgrBin = appmgr} <- ask
let pkgRoot = takeDirectory fp let pkgRoot = takeDirectory fp
manifestTask <- async $ runResourceT $ AppMgr.sourceManifest appmgr fp $ sinkIt (pkgRoot </> "manifest.json") manifestTask <- async $ runResourceT $ AppMgr.sourceManifest appmgr fp $ sinkIt (pkgRoot </> "manifest.json")
pkgHashTask <- async $ AppMgr.getPackageHash appmgr fp pkgHashTask <- async $ AppMgr.getPackageHash appmgr fp
instructionsTask <- async $ runResourceT $ AppMgr.sourceInstructions appmgr fp $ sinkIt instructionsTask <-
(pkgRoot </> "instructions.md") async $
runResourceT $
AppMgr.sourceInstructions appmgr fp $
sinkIt
(pkgRoot </> "instructions.md")
licenseTask <- async $ runResourceT $ AppMgr.sourceLicense appmgr fp $ sinkIt (pkgRoot </> "license.md") licenseTask <- async $ runResourceT $ AppMgr.sourceLicense appmgr fp $ sinkIt (pkgRoot </> "license.md")
iconTask <- async $ runResourceT $ AppMgr.sourceIcon appmgr fp $ sinkIt (pkgRoot </> "icon.tmp") iconTask <- async $ runResourceT $ AppMgr.sourceIcon appmgr fp $ sinkIt (pkgRoot </> "icon.tmp")
wait manifestTask wait manifestTask
eManifest <- liftIO (eitherDecodeFileStrict' (pkgRoot </> "manifest.json")) eManifest <- liftIO (eitherDecodeFileStrict' (pkgRoot </> "manifest.json"))
case eManifest of case eManifest of
@@ -242,11 +275,12 @@ extractPkg pool fp = handle @_ @SomeException cleanup $ do
liftIO . throwIO $ ManifestParseException (pkgRoot </> "manifest.json") liftIO . throwIO $ ManifestParseException (pkgRoot </> "manifest.json")
Right manifest -> do Right manifest -> do
wait iconTask wait iconTask
let iconDest = "icon" <.> case packageManifestIcon manifest of let iconDest =
Nothing -> "png" "icon" <.> case packageManifestIcon manifest of
Just x -> case takeExtension (T.unpack x) of Nothing -> "png"
"" -> "png" Just x -> case takeExtension (T.unpack x) of
other -> other "" -> "png"
other -> other
loadPkgDependencies pool manifest loadPkgDependencies pool manifest
liftIO $ renameFile (pkgRoot </> "icon.tmp") (pkgRoot </> iconDest) liftIO $ renameFile (pkgRoot </> "icon.tmp") (pkgRoot </> iconDest)
hash <- wait pkgHashTask hash <- wait pkgHashTask
@@ -263,97 +297,112 @@ extractPkg pool fp = handle @_ @SomeException cleanup $ do
mapConcurrently_ (removeFile . (pkgRoot </>)) toRemove mapConcurrently_ (removeFile . (pkgRoot </>)) toRemove
throwIO e throwIO e
watchEosRepoRoot :: (MonadUnliftIO m, MonadReader r m, Has EosRepo r, MonadLoggerIO m) => ConnectionPool -> m (IO Bool) watchEosRepoRoot :: (MonadUnliftIO m, MonadReader r m, Has EosRepo r, MonadLoggerIO m) => ConnectionPool -> m (IO Bool)
watchEosRepoRoot pool = do watchEosRepoRoot pool = do
$logInfo "Starting FSNotify Watch Manager: EOS" $logInfo "Starting FSNotify Watch Manager: EOS"
root <- asks eosRepoFileRoot root <- asks eosRepoFileRoot
runInIO <- askRunInIO runInIO <- askRunInIO
box <- newEmptyMVar @_ @() box <- newEmptyMVar @_ @()
_ <- forkIO $ liftIO $ withManager $ \watchManager -> do _ <- forkIO $
stop <- watchTree watchManager root shouldIndex $ \evt -> do liftIO $
let os = eventPath evt withManager $ \watchManager -> do
void . forkIO $ runInIO $ do stop <- watchTree watchManager root shouldIndex $ \evt -> do
indexOs pool os let os = eventPath evt
takeMVar box void . forkIO $
stop runInIO $ do
indexOs pool os
takeMVar box
stop
pure $ tryPutMVar box () pure $ tryPutMVar box ()
where where
shouldIndex :: ActionPredicate shouldIndex :: ActionPredicate
shouldIndex (Added path _ isDir) = not isDir && takeExtension path == ".img" shouldIndex (Added path _ isDir) = not isDir && takeExtension path == ".img"
shouldIndex (Modified path _ isDir) = not isDir && takeExtension path == ".img" shouldIndex (Modified path _ isDir) = not isDir && takeExtension path == ".img"
shouldIndex _ = False shouldIndex _ = False
indexOs :: (MonadUnliftIO m, MonadLoggerIO m) => ConnectionPool -> FilePath -> m () indexOs :: (MonadUnliftIO m, MonadLoggerIO m) => ConnectionPool -> FilePath -> m ()
indexOs pool path = do indexOs pool path = do
hash <- hashFile @_ @SHA256 path hash <- hashFile @_ @SHA256 path
let hashText = decodeUtf8 $ convertToBase Base16 hash let hashText = decodeUtf8 $ convertToBase Base16 hash
let vText = takeFileName (takeDirectory path) let vText = takeFileName (takeDirectory path)
let eVersion = parseOnly parseVersion . T.pack $ vText let eVersion = parseOnly parseVersion . T.pack $ vText
case eVersion of case eVersion of
Left e -> $logError [i|Invalid Version Number (#{vText}): #{e}|] Left e -> $logError [i|Invalid Version Number (#{vText}): #{e}|]
Right version -> Right version ->
void $ flip runSqlPool pool $ upsert (EosHash version hashText) [EosHashHash =. hashText] void $ flip runSqlPool pool $ upsert (EosHash version hashText) [EosHashHash =. hashText]
getManifestLocation :: (MonadReader r m, Has PkgRepo r) => PkgId -> Version -> m FilePath getManifestLocation :: (MonadReader r m, Has PkgRepo r) => PkgId -> Version -> m FilePath
getManifestLocation pkg version = do getManifestLocation pkg version = do
root <- asks pkgRepoFileRoot root <- asks pkgRepoFileRoot
pure $ root </> show pkg </> show version </> "manifest.json" pure $ root </> show pkg </> show version </> "manifest.json"
getManifest :: (MonadResource m, MonadReader r m, Has PkgRepo r)
=> PkgId getManifest ::
-> Version (MonadResource m, MonadReader r m, Has PkgRepo r) =>
-> m (Integer, ConduitT () ByteString m ()) PkgId ->
Version ->
m (Integer, ConduitT () ByteString m ())
getManifest pkg version = do getManifest pkg version = do
manifestPath <- getManifestLocation pkg version manifestPath <- getManifestLocation pkg version
n <- getFileSize manifestPath n <- getFileSize manifestPath
pure (n, sourceFile manifestPath) pure (n, sourceFile manifestPath)
getInstructions :: (MonadResource m, MonadReader r m, Has PkgRepo r)
=> PkgId getInstructions ::
-> Version (MonadResource m, MonadReader r m, Has PkgRepo r) =>
-> m (Integer, ConduitT () ByteString m ()) PkgId ->
Version ->
m (Integer, ConduitT () ByteString m ())
getInstructions pkg version = do getInstructions pkg version = do
root <- asks pkgRepoFileRoot root <- asks pkgRepoFileRoot
let instructionsPath = root </> show pkg </> show version </> "instructions.md" let instructionsPath = root </> show pkg </> show version </> "instructions.md"
n <- getFileSize instructionsPath n <- getFileSize instructionsPath
pure (n, sourceFile instructionsPath) pure (n, sourceFile instructionsPath)
getLicense :: (MonadResource m, MonadReader r m, Has PkgRepo r)
=> PkgId getLicense ::
-> Version (MonadResource m, MonadReader r m, Has PkgRepo r) =>
-> m (Integer, ConduitT () ByteString m ()) PkgId ->
Version ->
m (Integer, ConduitT () ByteString m ())
getLicense pkg version = do getLicense pkg version = do
root <- asks pkgRepoFileRoot root <- asks pkgRepoFileRoot
let licensePath = root </> show pkg </> show version </> "license.md" let licensePath = root </> show pkg </> show version </> "license.md"
n <- getFileSize licensePath n <- getFileSize licensePath
pure (n, sourceFile licensePath) pure (n, sourceFile licensePath)
getIcon :: (MonadResource m, MonadReader r m, Has PkgRepo r)
=> PkgId getIcon ::
-> Version (MonadResource m, MonadReader r m, Has PkgRepo r) =>
-> m (ContentType, Integer, ConduitT () ByteString m ()) PkgId ->
Version ->
m (ContentType, Integer, ConduitT () ByteString m ())
getIcon pkg version = do getIcon pkg version = do
root <- asks pkgRepoFileRoot root <- asks pkgRepoFileRoot
let pkgRoot = root </> show pkg </> show version let pkgRoot = root </> show pkg </> show version
mIconFile <- find ((== "icon") . takeBaseName) <$> listDirectory pkgRoot mIconFile <- find ((== "icon") . takeBaseName) <$> listDirectory pkgRoot
case mIconFile of case mIconFile of
Nothing -> throwIO $ NotFoundE [i|#{pkg}: Icon|] Nothing -> throwIO $ NotFoundE [i|#{pkg}: Icon|]
Just x -> do Just x -> do
let ct = case takeExtension x of let ct = case takeExtension x of
".png" -> typePng ".png" -> typePng
".jpg" -> typeJpeg ".jpg" -> typeJpeg
".jpeg" -> typeJpeg ".jpeg" -> typeJpeg
".svg" -> typeSvg ".svg" -> typeSvg
".gif" -> typeGif ".gif" -> typeGif
_ -> typePlain _ -> typePlain
n <- getFileSize (pkgRoot </> x) n <- getFileSize (pkgRoot </> x)
pure (ct, n, sourceFile (pkgRoot </> x)) pure (ct, n, sourceFile (pkgRoot </> x))
getHash :: (MonadIO m, MonadReader r m, Has PkgRepo r) => PkgId -> Version -> m ByteString getHash :: (MonadIO m, MonadReader r m, Has PkgRepo r) => PkgId -> Version -> m ByteString
getHash pkg version = do getHash pkg version = do
root <- asks pkgRepoFileRoot root <- asks pkgRepoFileRoot
let hashPath = root </> show pkg </> show version </> "hash.bin" let hashPath = root </> show pkg </> show version </> "hash.bin"
liftIO $ readFile hashPath liftIO $ readFile hashPath
getPackage :: (MonadResource m, MonadReader r m, Has PkgRepo r) => PkgId -> Version -> m (Maybe FilePath) getPackage :: (MonadResource m, MonadReader r m, Has PkgRepo r) => PkgId -> Version -> m (Maybe FilePath)
getPackage pkg version = do getPackage pkg version = do
root <- asks pkgRepoFileRoot root <- asks pkgRepoFileRoot

47
src/Lib/Registry.hs
View File

@@ -1,47 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module Lib.Registry where
import Startlude ( ($)
, (.)
, ConvertText(toS)
, Eq((==))
, KnownSymbol
, Proxy(Proxy)
, Read
, Show
, String
, Symbol
, readMaybe
, show
, symbolVal
)
import qualified GHC.Read ( Read(..) )
import qualified GHC.Show ( Show(..) )
import System.FilePath ( (<.>)
, splitExtension
)
import Yesod.Core ( PathPiece(..) )
newtype Extension (a :: Symbol) = Extension String deriving (Eq)
type S9PK = Extension "s9pk"
extension :: KnownSymbol a => Extension a -> String
extension = symbolVal
instance KnownSymbol a => Show (Extension a) where
show e@(Extension file) = file <.> extension e
instance KnownSymbol a => Read (Extension a) where
readsPrec _ s = case symbolVal $ Proxy @a of
"" -> [(Extension s, "")]
other -> [ (Extension file, "") | ext' == "" <.> other ]
where (file, ext') = splitExtension s
instance KnownSymbol a => PathPiece (Extension a) where
fromPathPiece = readMaybe . toS
toPathPiece = show

267
src/Lib/Types/AppIndex.hs
View File

@@ -1,267 +0,0 @@
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE QuasiQuotes #-}
module Lib.Types.AppIndex where
import Startlude
-- NOTE: leave eitherDecode for inline test evaluation below
import Control.Monad ( fail )
import Data.Aeson ( (.:)
, (.:?)
, FromJSON(..)
, FromJSONKey(..)
, ToJSON(..)
, ToJSONKey(..)
, withObject
)
import qualified Data.ByteString.Lazy as BS
import Data.Functor.Contravariant ( contramap )
import qualified Data.HashMap.Strict as HM
import Data.String.Interpolate.IsString
( i )
import qualified Data.Text as T
import Database.Persist ( PersistField(..)
, PersistValue(PersistText)
, SqlType(..)
)
import Database.Persist.Sql ( PersistFieldSql(sqlType) )
import GHC.Read ( Read(readsPrec) )
import Lib.Types.Emver ( Version
, VersionRange
)
import Orphans.Emver ( )
import qualified Protolude.Base as P
( Show(..) )
import Web.HttpApiData ( FromHttpApiData
, ToHttpApiData
)
import Yesod ( PathPiece(..) )
newtype PkgId = PkgId { unPkgId :: Text }
deriving stock (Eq, Ord)
deriving newtype (FromHttpApiData, ToHttpApiData)
instance IsString PkgId where
fromString = PkgId . fromString
instance P.Show PkgId where
show = toS . unPkgId
instance Read PkgId where
readsPrec _ s = [(PkgId $ toS s, "")]
instance Hashable PkgId where
hashWithSalt n = hashWithSalt n . unPkgId
instance FromJSON PkgId where
parseJSON = fmap PkgId . parseJSON
instance ToJSON PkgId where
toJSON = toJSON . unPkgId
instance FromJSONKey PkgId where
fromJSONKey = fmap PkgId fromJSONKey
instance ToJSONKey PkgId where
toJSONKey = contramap unPkgId toJSONKey
instance PersistField PkgId where
toPersistValue = PersistText . show
fromPersistValue (PersistText t) = Right . PkgId $ toS t
fromPersistValue other = Left [i|Invalid AppId: #{other}|]
instance PersistFieldSql PkgId where
sqlType _ = SqlString
instance PathPiece PkgId where
fromPathPiece = fmap PkgId . fromPathPiece
toPathPiece = unPkgId
data VersionInfo = VersionInfo
{ versionInfoVersion :: !Version
, versionInfoReleaseNotes :: !Text
, versionInfoDependencies :: !(HM.HashMap PkgId VersionRange)
, versionInfoOsVersion :: !Version
, versionInfoInstallAlert :: !(Maybe Text)
}
deriving (Eq, Show)
data PackageDependency = PackageDependency
{ packageDependencyOptional :: !(Maybe Text)
, packageDependencyVersion :: !VersionRange
, packageDependencyDescription :: !(Maybe Text)
}
deriving Show
instance FromJSON PackageDependency where
parseJSON = withObject "service dependency info" $ \o -> do
packageDependencyOptional <- o .:? "optional"
packageDependencyVersion <- o .: "version"
packageDependencyDescription <- o .:? "description"
pure PackageDependency { .. }
data ServiceAlert = INSTALL | UNINSTALL | RESTORE | START | STOP
deriving (Show, Eq, Generic, Hashable, Read)
data PackageManifest = PackageManifest
{ packageManifestId :: !PkgId
, packageManifestTitle :: !Text
, packageManifestVersion :: !Version
, packageManifestDescriptionLong :: !Text
, packageManifestDescriptionShort :: !Text
, packageManifestReleaseNotes :: !Text
, packageManifestIcon :: !(Maybe Text)
, packageManifestAlerts :: !(HM.HashMap ServiceAlert (Maybe Text))
, packageManifestDependencies :: !(HM.HashMap PkgId PackageDependency)
, packageManifestEosVersion :: !Version
}
deriving Show
instance FromJSON PackageManifest where
parseJSON = withObject "service manifest" $ \o -> do
packageManifestId <- o .: "id"
packageManifestTitle <- o .: "title"
packageManifestVersion <- o .: "version"
packageManifestDescriptionLong <- o .: "description" >>= (.: "long")
packageManifestDescriptionShort <- o .: "description" >>= (.: "short")
packageManifestIcon <- o .: "assets" >>= (.: "icon")
packageManifestReleaseNotes <- o .: "release-notes"
alerts <- o .: "alerts"
a <- for (HM.toList alerts) $ \(key, value) -> do
alertType <- case readMaybe $ T.toUpper key of
Nothing -> fail "could not parse alert key as ServiceAlert"
Just t -> pure t
alertDesc <- parseJSON value
pure (alertType, alertDesc)
let packageManifestAlerts = HM.fromList a
packageManifestDependencies <- o .: "dependencies"
packageManifestEosVersion <- o .: "eos-version"
pure PackageManifest { .. }
-- >>> eitherDecode testManifest :: Either String PackageManifest
testManifest :: BS.ByteString
testManifest = [i|{
"id": "embassy-pages",
"title": "Embassy Pages",
"version": "0.1.3",
"description": {
"short": "Create Tor websites, hosted on your Embassy.",
"long": "Embassy Pages is a simple web server that uses directories inside File Browser to serve Tor websites."
},
"assets": {
"license": "LICENSE",
"icon": "icon.png",
"docker-images": "image.tar",
"instructions": "instructions.md"
},
"build": [
"make"
],
"release-notes": "Upgrade to EmbassyOS v0.3.0",
"license": "nginx",
"wrapper-repo": "https://github.com/Start9Labs/embassy-pages-wrapper",
"upstream-repo": "http://hg.nginx.org/nginx/",
"support-site": null,
"marketing-site": null,
"alerts": {
"install": null,
"uninstall": null,
"restore": null,
"start": null,
"stop": null
},
"main": {
"type": "docker",
"image": "main",
"system": false,
"entrypoint": "/usr/local/bin/docker_entrypoint.sh",
"args": [],
"mounts": {
"filebrowser": "/mnt/filebrowser"
},
"io-format": "yaml",
"inject": false,
"shm-size-mb": null
},
"health-checks": {},
"config": {
"get": {
"type": "docker",
"image": "compat",
"system": true,
"entrypoint": "config",
"args": [
"get",
"/root"
],
"mounts": {},
"io-format": "yaml",
"inject": false,
"shm-size-mb": null
},
"set": {
"type": "docker",
"image": "compat",
"system": true,
"entrypoint": "config",
"args": [
"set",
"/root"
],
"mounts": {},
"io-format": "yaml",
"inject": false,
"shm-size-mb": null
}
},
"volumes": {
"filebrowser": {
"type": "pointer",
"package-id": "filebrowser",
"volume-id": "main",
"path": "/",
"readonly": true
}
},
"min-os-version": "0.3.0",
"interfaces": {
"main": {
"tor-config": {
"port-mapping": {
"80": "80"
}
},
"lan-config": null,
"ui": true,
"protocols": [
"tcp",
"http"
]
}
},
"backup": {
"create": {
"type": "docker",
"image": "compat",
"system": true,
"entrypoint": "true",
"args": [],
"mounts": {},
"io-format": null,
"inject": false,
"shm-size-mb": null
},
"restore": {
"type": "docker",
"image": "compat",
"system": true,
"entrypoint": "true",
"args": [],
"mounts": {},
"io-format": null,
"inject": false,
"shm-size-mb": null
}
},
"migrations": {
"from": {},
"to": {}
},
"actions": {},
"dependencies": {
"filebrowser": {
"version": ">=2.14.1.1 <3.0.0",
"optional": null,
"description": "Used to upload files to serve.",
"critical": false,
"config": null
}
}
}|]

108
src/Lib/Types/Core.hs Normal file
View File

@@ -0,0 +1,108 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
module Lib.Types.Core where
import Startlude (
ConvertText (toS),
Either (Left, Right),
Eq ((==)),
Functor (fmap),
Hashable (hashWithSalt),
IsString (..),
KnownSymbol,
Ord,
Proxy (Proxy),
Read,
Show,
String,
Symbol,
Text,
readMaybe,
show,
symbolVal,
($),
(.),
)
import Data.Aeson (
FromJSON (..),
FromJSONKey (..),
ToJSON (..),
ToJSONKey (..),
)
import Data.Functor.Contravariant (contramap)
import Data.String.Interpolate.IsString (
i,
)
import Database.Persist (
PersistField (..),
PersistValue (PersistText),
SqlType (..),
)
import Database.Persist.Sql (PersistFieldSql (sqlType))
import GHC.Read (Read (readsPrec))
import Orphans.Emver ()
import Protolude.Base qualified as P (
Show (..),
)
import System.FilePath (splitExtension, (<.>))
import Web.HttpApiData (
FromHttpApiData,
ToHttpApiData,
)
import Yesod (PathPiece (..))
newtype PkgId = PkgId {unPkgId :: Text}
deriving stock (Eq, Ord)
deriving newtype (FromHttpApiData, ToHttpApiData)
instance IsString PkgId where
fromString = PkgId . fromString
instance P.Show PkgId where
show = toS . unPkgId
instance Read PkgId where
readsPrec _ s = [(PkgId $ toS s, "")]
instance Hashable PkgId where
hashWithSalt n = hashWithSalt n . unPkgId
instance FromJSON PkgId where
parseJSON = fmap PkgId . parseJSON
instance ToJSON PkgId where
toJSON = toJSON . unPkgId
instance FromJSONKey PkgId where
fromJSONKey = fmap PkgId fromJSONKey
instance ToJSONKey PkgId where
toJSONKey = contramap unPkgId toJSONKey
instance PersistField PkgId where
toPersistValue = PersistText . show
fromPersistValue (PersistText t) = Right . PkgId $ toS t
fromPersistValue other = Left [i|Invalid AppId: #{other}|]
instance PersistFieldSql PkgId where
sqlType _ = SqlString
instance PathPiece PkgId where
fromPathPiece = fmap PkgId . fromPathPiece
toPathPiece = unPkgId
newtype Extension (a :: Symbol) = Extension String deriving (Eq)
type S9PK = Extension "s9pk"
instance KnownSymbol a => Show (Extension a) where
show e@(Extension file) = file <.> extension e
instance KnownSymbol a => Read (Extension a) where
readsPrec _ s = case symbolVal $ Proxy @a of
"" -> [(Extension s, "")]
other -> [(Extension file, "") | ext' == "" <.> other]
where
(file, ext') = splitExtension s
instance KnownSymbol a => PathPiece (Extension a) where
fromPathPiece = readMaybe . toS
toPathPiece = show
extension :: KnownSymbol a => Extension a -> String
extension = symbolVal

211
src/Lib/Types/Manifest.hs Normal file
View File

@@ -0,0 +1,211 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
module Lib.Types.Manifest where
import Control.Monad.Fail (MonadFail (..))
import Data.Aeson (FromJSON (..), withObject, (.:), (.:?))
import Data.HashMap.Internal.Strict (HashMap)
import Data.HashMap.Strict qualified as HM
import Data.String.Interpolate.IsString (i)
import Data.Text qualified as T
import Lib.Types.Core (PkgId)
import Lib.Types.Emver (Version (..), VersionRange)
import Startlude (ByteString, Eq, Generic, Hashable, Maybe (..), Monad ((>>=)), Read, Show, Text, for, pure, readMaybe, ($))
data PackageManifest = PackageManifest
{ packageManifestId :: !PkgId
, packageManifestTitle :: !Text
, packageManifestVersion :: !Version
, packageManifestDescriptionLong :: !Text
, packageManifestDescriptionShort :: !Text
, packageManifestReleaseNotes :: !Text
, packageManifestIcon :: !(Maybe Text)
, packageManifestAlerts :: !(HashMap ServiceAlert (Maybe Text))
, packageManifestDependencies :: !(HashMap PkgId PackageDependency)
, packageManifestEosVersion :: !Version
}
deriving (Show)
instance FromJSON PackageManifest where
parseJSON = withObject "service manifest" $ \o -> do
packageManifestId <- o .: "id"
packageManifestTitle <- o .: "title"
packageManifestVersion <- o .: "version"
packageManifestDescriptionLong <- o .: "description" >>= (.: "long")
packageManifestDescriptionShort <- o .: "description" >>= (.: "short")
packageManifestIcon <- o .: "assets" >>= (.: "icon")
packageManifestReleaseNotes <- o .: "release-notes"
alerts <- o .: "alerts"
a <- for (HM.toList alerts) $ \(key, value) -> do
alertType <- case readMaybe $ T.toUpper key of
Nothing -> fail "could not parse alert key as ServiceAlert"
Just t -> pure t
alertDesc <- parseJSON value
pure (alertType, alertDesc)
let packageManifestAlerts = HM.fromList a
packageManifestDependencies <- o .: "dependencies"
packageManifestEosVersion <- o .: "eos-version"
pure PackageManifest{..}
data PackageDependency = PackageDependency
{ packageDependencyOptional :: !(Maybe Text)
, packageDependencyVersion :: !VersionRange
, packageDependencyDescription :: !(Maybe Text)
}
deriving (Show)
instance FromJSON PackageDependency where
parseJSON = withObject "service dependency info" $ \o -> do
packageDependencyOptional <- o .:? "optional"
packageDependencyVersion <- o .: "version"
packageDependencyDescription <- o .:? "description"
pure PackageDependency{..}
data ServiceAlert = INSTALL | UNINSTALL | RESTORE | START | STOP
deriving (Show, Eq, Generic, Hashable, Read)
-- >>> eitherDecode testManifest :: Either String PackageManifest
testManifest :: ByteString
testManifest =
[i|{
"id": "embassy-pages",
"title": "Embassy Pages",
"version": "0.1.3",
"description": {
"short": "Create Tor websites, hosted on your Embassy.",
"long": "Embassy Pages is a simple web server that uses directories inside File Browser to serve Tor websites."
},
"assets": {
"license": "LICENSE",
"icon": "icon.png",
"docker-images": "image.tar",
"instructions": "instructions.md"
},
"build": [
"make"
],
"release-notes": "Upgrade to EmbassyOS v0.3.0",
"license": "nginx",
"wrapper-repo": "https://github.com/Start9Labs/embassy-pages-wrapper",
"upstream-repo": "http://hg.nginx.org/nginx/",
"support-site": null,
"marketing-site": null,
"alerts": {
"install": null,
"uninstall": null,
"restore": null,
"start": null,
"stop": null
},
"main": {
"type": "docker",
"image": "main",
"system": false,
"entrypoint": "/usr/local/bin/docker_entrypoint.sh",
"args": [],
"mounts": {
"filebrowser": "/mnt/filebrowser"
},
"io-format": "yaml",
"inject": false,
"shm-size-mb": null
},
"health-checks": {},
"config": {
"get": {
"type": "docker",
"image": "compat",
"system": true,
"entrypoint": "config",
"args": [
"get",
"/root"
],
"mounts": {},
"io-format": "yaml",
"inject": false,
"shm-size-mb": null
},
"set": {
"type": "docker",
"image": "compat",
"system": true,
"entrypoint": "config",
"args": [
"set",
"/root"
],
"mounts": {},
"io-format": "yaml",
"inject": false,
"shm-size-mb": null
}
},
"volumes": {
"filebrowser": {
"type": "pointer",
"package-id": "filebrowser",
"volume-id": "main",
"path": "/",
"readonly": true
}
},
"min-os-version": "0.3.0",
"interfaces": {
"main": {
"tor-config": {
"port-mapping": {
"80": "80"
}
},
"lan-config": null,
"ui": true,
"protocols": [
"tcp",
"http"
]
}
},
"backup": {
"create": {
"type": "docker",
"image": "compat",
"system": true,
"entrypoint": "true",
"args": [],
"mounts": {},
"io-format": null,
"inject": false,
"shm-size-mb": null
},
"restore": {
"type": "docker",
"image": "compat",
"system": true,
"entrypoint": "true",
"args": [],
"mounts": {},
"io-format": null,
"inject": false,
"shm-size-mb": null
}
},
"migrations": {
"from": {},
"to": {}
},
"actions": {},
"dependencies": {
"filebrowser": {
"version": ">=2.14.1.1 <3.0.0",
"optional": null,
"description": "Used to upload files to serve.",
"critical": false,
"config": null
}
}
}|]

71
src/Model.hs
View File

@@ -1,40 +1,47 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GADTs #-} {-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
module Model where module Model where
import Crypto.Hash ( Digest import Crypto.Hash (
, SHA256 Digest,
) SHA256,
import Database.Persist.TH ( mkMigrate )
, mkPersist import Database.Persist.TH (
, persistLowerCase mkMigrate,
, share mkPersist,
, sqlSettings persistLowerCase,
) share,
import Lib.Types.AppIndex ( PkgId(PkgId) ) sqlSettings,
import Lib.Types.Emver ( Version )
, VersionRange import Lib.Types.Core (PkgId (PkgId))
) import Lib.Types.Emver (
import Orphans.Cryptonite ( ) Version,
import Orphans.Emver ( ) VersionRange,
import Startlude ( Eq )
, Int import Orphans.Cryptonite ()
, Show import Orphans.Emver ()
, Text import Startlude (
, UTCTime Eq,
, Word32 Int,
) Show,
Text,
UTCTime,
Word32,
)
share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
share
[mkPersist sqlSettings, mkMigrate "migrateAll"]
[persistLowerCase|
PkgRecord PkgRecord
Id PkgId sql=pkg_id Id PkgId sql=pkg_id
createdAt UTCTime createdAt UTCTime

72
src/Startlude.hs
View File

@@ -1,33 +1,51 @@
module Startlude module Startlude (
( module X module X,
, module Startlude module Startlude,
) where ) where
import Control.Arrow as X (
(&&&),
)
import Control.Error.Util as X
import Data.Coerce as X
import Data.String as X (
String,
fromString,
)
import Data.Time.Clock as X
import Protolude as X hiding (
bool,
hush,
isLeft,
isRight,
note,
readMaybe,
tryIO,
(<.>),
)
import Protolude qualified as P (
readMaybe,
)
import Control.Arrow as X
( (&&&) )
import Control.Error.Util as X
import Data.Coerce as X
import Data.String as X
( String
, fromString
)
import Data.Time.Clock as X
import Protolude as X
hiding ( (<.>)
, bool
, hush
, isLeft
, isRight
, note
, readMaybe
, tryIO
)
import qualified Protolude as P
( readMaybe )
id :: a -> a id :: a -> a
id = identity id = identity
readMaybe :: Read a => Text -> Maybe a
readMaybe = P.readMaybe . toS readMaybe :: (Read a) => Text -> Maybe a
readMaybe = P.readMaybe
{-# INLINE readMaybe #-} {-# INLINE readMaybe #-}
maximumOn :: forall a b t. (Ord b, Foldable t) => (a -> b) -> t a -> Maybe a
maximumOn f = foldr (\x y -> maxOn f x <$> y <|> Just x) Nothing
maxOn :: Ord b => (a -> b) -> a -> a -> a
maxOn f x y = if f x > f y then x else y
{-# INLINE (.*) #-}
infixr 8 .*
(.*) :: (b -> c) -> (a1 -> a2 -> b) -> a1 -> a2 -> c
(.*) = (.) . (.)

171
src/Util/Shared.hs
View File

@@ -1,171 +0,0 @@
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}
module Util.Shared where
import qualified Data.Text as T
import Network.HTTP.Types ( Status
, status400
)
import Yesod.Core ( MonadHandler
, MonadLogger
, MonadUnliftIO
, ToContent(toContent)
, TypedContent(TypedContent)
, addHeader
, logInfo
, lookupGetParam
, sendResponseStatus
, typePlain
)
import Conduit ( ConduitT
, awaitForever
, yield
)
import Control.Monad.Reader.Has ( Has
, MonadReader
)
import Data.Semigroup ( (<>) )
import Data.String.Interpolate.IsString
( i )
import Database.Esqueleto.Experimental
( Entity
, Key
, entityVal
)
import Foundation ( Handler )
import GHC.List ( lookup )
import Handler.Types.Marketplace ( PackageDependencyMetadata(..)
, PackageMetadata(..)
)
import Lib.PkgRepository ( PkgRepo
, getHash
)
import Lib.Types.AppIndex ( PkgId )
import Lib.Types.Emver ( (<||)
, Version
, VersionRange(Any)
, satisfies
)
import Model ( Category
, PkgDependency(pkgDependencyDepId, pkgDependencyDepVersionRange)
, PkgRecord
, VersionRecord(..)
, pkgDependencyPkgId
)
import Startlude ( ($)
, (.)
, (<$>)
, Alternative((<|>))
, Applicative(pure)
, Bool(..)
, Down(Down)
, Foldable(foldr, null)
, Functor(fmap)
, Maybe(..)
, Monad((>>=))
, Ord((>))
, Text
, decodeUtf8
, filter
, fromMaybe
, headMay
, isSpace
, not
, readMaybe
, sortOn
, unless
)
getVersionSpecFromQuery :: Handler VersionRange
getVersionSpecFromQuery = do
specString <- T.filter (not . isSpace) . fromMaybe "*" <$> lookupGetParam "spec"
case readMaybe specString of
Nothing -> sendResponseStatus status400 ("Invalid App Version Specification" :: Text)
Just t -> pure t
versionPriorityFromQueryIsMin :: Handler Bool
versionPriorityFromQueryIsMin = do
priorityString <- lookupGetParam "version-priority"
case priorityString of
Nothing -> pure False
(Just "max") -> pure False
(Just "min") -> pure True
(Just t ) -> sendResponseStatus status400 ("Invalid Version Priority Specification: " <> t)
addPackageHeader :: (MonadUnliftIO m, MonadHandler m, MonadReader r m, Has PkgRepo r) => PkgId -> Version -> m ()
addPackageHeader pkg version = do
packageHash <- getHash pkg version
addHeader "X-S9PK-HASH" $ decodeUtf8 packageHash
orThrow :: MonadHandler m => m (Maybe a) -> m a -> m a
orThrow action other = action >>= \case
Nothing -> other
Just x -> pure x
filterPkgOsCompatible :: Monad m => (Version -> Bool) -> ConduitT PackageMetadata PackageMetadata m ()
filterPkgOsCompatible p =
awaitForever
$ \PackageMetadata { packageMetadataPkgId = pkg, packageMetadataPkgVersionRecords = versions, packageMetadataPkgCategories = cats, packageMetadataPkgVersion = requestedVersion } ->
do
let compatible = filter (p . versionRecordOsVersion . entityVal) versions
unless (null compatible) $ yield PackageMetadata { packageMetadataPkgId = pkg
, packageMetadataPkgVersionRecords = compatible
, packageMetadataPkgCategories = cats
, packageMetadataPkgVersion = requestedVersion
}
filterDependencyOsCompatible :: (Version -> Bool) -> PackageDependencyMetadata -> PackageDependencyMetadata
filterDependencyOsCompatible p PackageDependencyMetadata { packageDependencyMetadataPkgDependencyRecord = pkgDeps, packageDependencyMetadataDepPkgRecord = pkg, packageDependencyMetadataDepVersions = depVersions }
= do
let compatible = filter (p . versionRecordOsVersion . entityVal) depVersions
PackageDependencyMetadata { packageDependencyMetadataPkgDependencyRecord = pkgDeps
, packageDependencyMetadataDepPkgRecord = pkg
, packageDependencyMetadataDepVersions = compatible
}
filterLatestVersionFromSpec :: (Monad m, MonadLogger m)
=> [(PkgId, VersionRange)]
-> ConduitT (PkgId, [Entity VersionRecord], [Entity Category]) PackageMetadata m ()
filterLatestVersionFromSpec versionMap = awaitForever $ \(pkgId, vs, cats) -> do
-- if no packages are specified, the VersionRange is implicitly `*`
let spec = fromMaybe Any $ lookup pkgId versionMap
case headMay . sortOn Down $ filter (`satisfies` spec) $ fmap (versionRecordNumber . entityVal) vs of
Nothing -> $logInfo [i|No version for #{pkgId} satisfying #{spec}|]
Just v -> yield $ PackageMetadata { packageMetadataPkgId = pkgId
, packageMetadataPkgVersionRecords = vs
, packageMetadataPkgCategories = cats
, packageMetadataPkgVersion = v
}
-- get best version of the dependency based on what is specified in the db (ie. what is specified in the manifest for the package)
filterDependencyBestVersion :: MonadLogger m => PackageDependencyMetadata -> m (Maybe (Key PkgRecord, Text, Version))
filterDependencyBestVersion PackageDependencyMetadata { packageDependencyMetadataPkgDependencyRecord = pkgDepRecord, packageDependencyMetadataDepVersions = depVersions }
= do
-- get best version from VersionRange of dependency
let pkgId = pkgDependencyPkgId $ entityVal pkgDepRecord
let depId = pkgDependencyDepId $ entityVal pkgDepRecord
let versionRequirement = pkgDependencyDepVersionRange $ entityVal pkgDepRecord
let satisfactory = filter ((<|| versionRequirement) . versionRecordNumber) (entityVal <$> depVersions)
case maximumOn versionRecordNumber satisfactory of
Just bestVersion -> pure $ Just (depId, versionRecordTitle bestVersion, versionRecordNumber bestVersion)
Nothing -> do
$logInfo
[i|No satisfactory version of #{depId} for dependent package #{pkgId}, needs #{versionRequirement}|]
pure Nothing
sendResponseText :: MonadHandler m => Status -> Text -> m a
sendResponseText s = sendResponseStatus s . TypedContent typePlain . toContent
maximumOn :: forall a b t . (Ord b, Foldable t) => (a -> b) -> t a -> Maybe a
maximumOn f = foldr (\x y -> maxOn f x <$> y <|> Just x) Nothing
maxOn :: Ord b => (a -> b) -> a -> a -> a
maxOn f x y = if f x > f y then x else y

10
stack.yaml
View File

@@ -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.11 resolver: nightly-2022-06-06
# 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.
@@ -40,15 +40,9 @@ packages:
# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
# #
extra-deps: extra-deps:
- protolude-0.3.0 - protolude-0.3.1
- esqueleto-3.5.1.0
- monad-logger-extras-0.1.1.1 - monad-logger-extras-0.1.1.1
- persistent-migration-0.3.0 - persistent-migration-0.3.0
- rainbow-0.34.2.2
- terminal-progress-bar-0.4.1
- wai-request-spec-0.10.2.4
- warp-3.3.19
- yesod-auth-basic-0.1.0.3
# Override default flag values for local packages and extra-deps # Override default flag values for local packages and extra-deps
# flags: {} # flags: {}