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.pdf
start9-registry.aux
start9-registry.ps
start9-registry.ps
shell.nix
testdata/

2
Makefile
View File

@@ -1,2 +1,4 @@
all:
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
-- PACKAGE API V0
/package/v0/info InfoR GET -- get all marketplace categories
/package/v0/index PackageListR GET -- filter marketplace services by various query params
/package/v0/latest VersionLatestR GET -- get latest version of apps in query param id
!/package/v0/#S9PK AppR GET -- get most recent appId at appversion spec, defaults to >=0.0.0 -- ?spec=<emver>
/package/v0/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/v0/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/v0/instructions/#PkgId InstructionsR GET -- get instructions - can specify version with ?spec=<emver>
/package/v0/version/#PkgId PkgVersionR GET -- get most recent appId version
-- SUPPORT API V0
/support/v0/error-logs ErrorLogsR POST
/package/#ApiVersion/info InfoR GET -- get all marketplace categories
/package/#ApiVersion/index PackageIndexR GET -- filter marketplace services by various query params
/package/#ApiVersion/latest VersionLatestR GET -- get latest version of apps in query param id
!/package/#ApiVersion/#S9PK AppR GET -- get most recent appId at appversion spec, defaults to >=0.0.0 -- ?spec=<emver>
/package/#ApiVersion/manifest/#PkgId AppManifestR GET -- get app manifest from appmgr -- ?spec=<emver>
/package/#ApiVersion/release-notes/#PkgId ReleaseNotesR GET -- get release notes for all versions of a package
/package/#ApiVersion/icon/#PkgId IconsR GET -- get icons - can specify version with ?spec=<emver>
/package/#ApiVersion/license/#PkgId LicenseR GET -- get license - can specify version with ?spec=<emver>
/package/#ApiVersion/instructions/#PkgId InstructionsR GET -- get instructions - can specify version with ?spec=<emver>
/package/#ApiVersion/version/#PkgId PkgVersionR GET -- get most recent appId version
-- ADMIN API V0
/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
default-extensions:
- FlexibleInstances
- GeneralizedNewtypeDeriving
- LambdaCase
- MultiWayIf
- NamedFieldPuns
- NoImplicitPrelude
- NumericUnderscores
- GHC2021
- LambdaCase
- OverloadedStrings
- StandaloneDeriving
dependencies:
- base >=4.12 && <5

667
src/Application.hs
View File

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

647
src/Cli/Cli.hs
View File

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

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

394
src/Foundation.hs
View File

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

345
src/Handler/Admin.hs
View File

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

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

473
src/Lib/PkgRepository.hs
View File

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

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

72
src/Startlude.hs
View File

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

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: https://example.com/snapshots/2018-01-01.yaml
resolver: lts-18.11
resolver: nightly-2022-06-06
# User packages to be built.
# Various formats can be used as shown in the example below.
@@ -40,15 +40,9 @@ packages:
# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
#
extra-deps:
- protolude-0.3.0
- esqueleto-3.5.1.0
- protolude-0.3.1
- monad-logger-extras-0.1.1.1
- persistent-migration-0.3.0
- rainbow-0.34.2.2
- terminal-progress-bar-0.4.1
- wai-request-spec-0.10.2.4
- warp-3.3.19
- yesod-auth-basic-0.1.0.3
# Override default flag values for local packages and extra-deps
# flags: {}