diff --git a/.gitignore b/.gitignore index 8838380..65bca3c 100644 --- a/.gitignore +++ b/.gitignore @@ -39,3 +39,4 @@ start9-registry.ps shell.nix testdata/ lbuild.sh +icon \ No newline at end of file diff --git a/config/settings.yml b/config/settings.yml index 77ab0d6..f3d4114 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -31,11 +31,13 @@ detailed-logging: true resources-path: "_env:RESOURCES_PATH:/var/www/html/resources" ssl-path: "_env:SSL_PATH:/var/ssl" ssl-auto: "_env:SSL_AUTO:true" -registry-hostname: "_env:REGISTRY_HOSTNAME:alpha-registry.start9labs.com" +registry-hostname: "_env:REGISTRY_HOSTNAME:alpha-registry-x.start9.com" tor-port: "_env:TOR_PORT:447" static-bin-dir: "_env:STATIC_BIN:/usr/local/bin/" -error-log-root: "_env:ERROR_LOG_ROOT:/var/log/embassy-os/" +error-log-root: "_env:ERROR_LOG_ROOT:/var/log/registry/" marketplace-name: "_env:MARKETPLACE_NAME:CHANGE ME" +max-eos-version: "_env:MAX_VERSION:0.3.3.0" +run-migration: "_env:RUN_MIGRATION:false" database: database: "_env:PG_DATABASE:start9_registry" diff --git a/src/Application.hs b/src/Application.hs index b0ded17..839a590 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -254,11 +254,14 @@ makeFoundation appSettings = do flip runLoggingT logFunc $ createPostgresqlPool (pgConnStr $ appDatabaseConf appSettings) (pgPoolSize . appDatabaseConf $ appSettings) - runSqlPool - (Database.Persist.Migration.Postgres.runMigration Database.Persist.Migration.defaultSettings manualMigration) - pool - -- Preform database migration using application logging settings - runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc + if (needsMigration appSettings) + then + runSqlPool + (Database.Persist.Migration.Postgres.runMigration Database.Persist.Migration.defaultSettings manualMigration) + pool + else + -- Preform database migration using application logging settings + runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc -- Return the foundation return $ mkFoundation pool diff --git a/src/Cli/Cli.hs b/src/Cli/Cli.hs index 615c5ef..6c06234 100644 --- a/src/Cli/Cli.hs +++ b/src/Cli/Cli.hs @@ -13,15 +13,8 @@ module Cli.Cli ( ) where import Conduit ( - ConduitT, - MonadIO, - awaitForever, foldC, runConduit, - runConduitRes, - sinkFileCautious, - sourceFile, - yield, (.|), ) import Control.Monad.Logger ( @@ -36,7 +29,6 @@ import Crypto.Hash ( SHA256 (SHA256), hashWith, ) -import Crypto.Hash.Conduit (hashFile, sinkHash) import Data.Aeson ( ToJSON, eitherDecodeStrict, @@ -48,7 +40,6 @@ import Data.ByteArray.Encoding ( import Data.ByteString.Char8 qualified as B8 import Data.ByteString.Lazy qualified as LB import Data.Conduit.Process (readProcess) -import Data.Conduit.Zlib (gzip) import Data.Default import Data.Functor.Contravariant (contramap) import Data.HashMap.Internal.Strict ( @@ -99,7 +90,6 @@ import Network.HTTP.Simple ( setRequestBody, setRequestBodyJSON, setRequestHeaders, - setRequestQueryString, setRequestResponseTimeout, ) import Network.HTTP.Types (status200) @@ -163,7 +153,6 @@ import Startlude ( ReaderT (runReaderT), Semigroup ((<>)), Show, - SomeException, String, appendFile, const, @@ -178,12 +167,10 @@ import Startlude ( fromMaybe, fst, headMay, - liftIO, not, panic, show, snd, - throwIO, unlessM, void, when, @@ -202,7 +189,6 @@ import System.Directory ( getFileSize, getHomeDirectory, listDirectory, - removeFile, ) import System.FilePath ( takeDirectory, @@ -211,15 +197,10 @@ import System.FilePath ( ) import System.ProgressBar ( Progress (..), - ProgressBar, - Style (stylePrefix), defStyle, - incProgress, - msg, newProgressBar, updateProgress, ) -import UnliftIO.Exception (handle) import Yesod ( logError, logWarn, @@ -233,15 +214,6 @@ data Upload = Upload } deriving (Show) - -data EosUpload = EosUpload - { eosRepoName :: !String - , eosPath :: !FilePath - , eosVersion :: !Version - } - deriving (Show) - - newtype PublishCfg = PublishCfg { publishCfgRepos :: HashMap String PublishCfgRepo } @@ -287,7 +259,6 @@ data Command | CmdCatDel !String !String | CmdPkgCatAdd !String !PkgId !String | CmdPkgCatDel !String !PkgId !String - | CmdEosUpload !EosUpload deriving (Show) @@ -401,7 +372,6 @@ parseCommand = <|> (CmdListUnindexed <$> parseListUnindexed) <|> parseCat <|> parsePkgCat - <|> (CmdEosUpload <$> parseEosPublish) where reg = parseRepoAdd <|> (CmdRegDel <$> parseRepoDel) <|> (parseRepoList $> CmdRegList) @@ -448,22 +418,6 @@ parsePkgCat = subparser $ command "categorize" (info cat $ progDesc "Add or remo <*> strArgument (metavar "PACKAGE_ID") <*> strArgument (metavar "CATEGORY") - -parseEosPublish :: Parser EosUpload -parseEosPublish = - subparser $ - command "eos-upload" (info go $ progDesc "Publishes a .img to a remote registry") - <> metavar - "eos-upload" - where - go = - liftA3 - EosUpload - (strOption (short 't' <> long "target" <> metavar "NAME" <> help "Name of registry in publish.dhall")) - (strOption (short 'i' <> long "image" <> metavar "EOS_IMG" <> help "File path of the image to publish")) - (strOption (short 'v' <> long "version" <> help "Version of the image")) - - opts :: ParserInfo Command opts = info (parseCommand <**> helper) (fullDesc <> progDesc "Publish tool for Embassy Packages") @@ -482,8 +436,6 @@ cliMain = CmdCatDel target cat -> catDel target cat CmdPkgCatAdd target pkg cat -> pkgCatAdd target pkg cat CmdPkgCatDel target pkg cat -> pkgCatDel target pkg cat - CmdEosUpload up -> eosUpload up - init :: Maybe Shell -> IO () init sh = do @@ -563,7 +515,7 @@ upload (Upload name mpkg shouldIndex) = do noBody <- parseRequest ("POST " <> show publishCfgRepoLocation <> "/admin/v0/upload") <&> setRequestHeaders [("accept", "text/plain")] - <&> setRequestResponseTimeout (responseTimeoutMicro (90_000_000)) -- 90 seconds + <&> setRequestResponseTimeout (responseTimeoutMicro (600_000_000)) -- 10 minutes <&> applyBasicAuth (B8.pack publishCfgRepoUser) (B8.pack publishCfgRepoPass) size <- getFileSize pkg bar <- newProgressBar defStyle 30 (Progress 0 (fromIntegral size) ()) @@ -593,59 +545,6 @@ upload (Upload name mpkg shouldIndex) = do sfs2prog :: StreamFileStatus -> Progress () sfs2prog StreamFileStatus{..} = Progress (fromIntegral readSoFar) (fromIntegral fileSize) () - -eosUpload :: EosUpload -> IO () -eosUpload (EosUpload name img version) = handle @_ @SomeException cleanup $ do - PublishCfgRepo{..} <- findNameInCfg name - noBody <- - parseRequest ("POST " <> show publishCfgRepoLocation <> "/admin/v0/eos-upload") - <&> setRequestHeaders [("accept", "text/plain")] - <&> setRequestResponseTimeout (responseTimeoutMicro (90_000_000)) -- 90 seconds - <&> setRequestHeaders [("Content-Encoding", "gzip")] - <&> applyBasicAuth (B8.pack publishCfgRepoUser) (B8.pack publishCfgRepoPass) - size <- getFileSize img - hashBar <- newProgressBar defStyle{stylePrefix = msg "Hashing"} 30 (Progress 0 (fromIntegral size) ()) - runConduitRes $ sourceFile img .| transByteCounter hashBar .| sinkHash @_ @SHA256 - hash <- hashFile @_ @SHA256 img - let compressedFilePath = "/tmp/eos.img.gz" - zipBar <- newProgressBar defStyle{stylePrefix = msg "Gzipping"} 30 (Progress 0 (fromIntegral size) ()) - runConduitRes $ - sourceFile img - .| transByteCounter zipBar - .| gzip - .| sinkFileCautious compressedFilePath - compressedSize <- getFileSize compressedFilePath - fileBar <- newProgressBar defStyle{stylePrefix = msg "Uploading"} 30 (Progress 0 (fromIntegral compressedSize) ()) - body <- observedStreamFile (updateProgress fileBar . const . sfs2prog) $ compressedFilePath - let withBody = setRequestBody body noBody - let withQParams = - setRequestQueryString - [("version", Just $ show version), ("hash", Just $ convertToBase Base16 hash)] - withBody - manager <- newTlsManager - res <- runReaderT (httpLbs withQParams) manager - removeFile compressedFilePath - if getResponseStatus res == status200 - then -- no output is successful - pure () - else do - $logError (decodeUtf8 . LB.toStrict $ getResponseBody res) - exitWith $ ExitFailure 1 - putChunkLn $ fromString ("Successfully uploaded " <> img) & fore green - where - sfs2prog :: StreamFileStatus -> Progress () - sfs2prog StreamFileStatus{..} = Progress (fromIntegral readSoFar) (fromIntegral fileSize) () - transByteCounter :: MonadIO m => ProgressBar a -> ConduitT B8.ByteString B8.ByteString m () - transByteCounter bar = awaitForever $ \bs -> do - let len = B8.length bs - liftIO $ incProgress bar len - yield bs - cleanup e = do - $logError $ show e - removeFile "/tmp/eos.img.gz" - throwIO e - - index :: String -> String -> Version -> IO () index name pkg v = performHttp name "POST" [i|/admin/v0/index|] (IndexPkgReq (PkgId $ toS pkg) v) diff --git a/src/Database/Queries.hs b/src/Database/Queries.hs index 9aa0400..cb5a43f 100644 --- a/src/Database/Queries.hs +++ b/src/Database/Queries.hs @@ -7,19 +7,19 @@ module Database.Queries where import Database.Persist.Sql ( PersistStoreRead (get), - PersistStoreWrite (insertKey, insert_, repsert), + PersistStoreWrite (insertKey, insert_, repsertMany, repsert), SqlBackend, ) import Lib.Types.Core ( - PkgId, + PkgId, OsArch (X86_64, AARCH64), ) import Lib.Types.Emver (Version) import Model ( - Key (PkgRecordKey, VersionRecordKey), + Key (PkgRecordKey, VersionRecordKey, VersionPlatformKey), Metric (Metric), PkgDependency (..), PkgRecord (PkgRecord), - VersionRecord (VersionRecord), + VersionRecord (VersionRecord), VersionPlatform (VersionPlatform), EntityField (VersionPlatformPkgId, VersionPlatformVersionNumber, VersionPlatformArch), ) import Orphans.Emver () import Startlude ( @@ -123,31 +123,62 @@ serviceQuerySource :: (MonadResource m, MonadIO m) => Maybe Text -> Text -> + Maybe OsArch -> ConduitT () (Entity VersionRecord) (ReaderT SqlBackend m) () -serviceQuerySource mCat query = selectSource $ do - service <- case mCat of +serviceQuerySource mCat query mOsArch = selectSource $ do + case mOsArch of + Just osArch -> do + service <- case mCat of + Nothing -> do + (service :& vp) <- from $ table @VersionRecord + `innerJoin` table @VersionPlatform `on` (\(service :& vp) -> (VersionPlatformPkgId === VersionRecordPkgId) (vp :& service)) + where_ (service ^. VersionRecordNumber ==. vp ^. VersionPlatformVersionNumber) + where_ (vp ^. VersionPlatformArch ==. val osArch) + where_ $ queryInMetadata query service + pure service + Just category -> do + (service :& _ :& cat :& vp) <- + from $ + table @VersionRecord + `innerJoin` table @PkgCategory `on` (VersionRecordPkgId === PkgCategoryPkgId) + `innerJoin` table @Category `on` (\(_ :& a :& b) -> (PkgCategoryCategoryId === CategoryId) (a :& b)) + `innerJoin` table @VersionPlatform `on` (\(service :& _ :& _ :& vp) -> (VersionPlatformPkgId === VersionRecordPkgId) (vp :& service)) + -- 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 + where_ (service ^. VersionRecordNumber ==. vp ^. VersionPlatformVersionNumber) + where_ (vp ^. VersionPlatformArch ==. val osArch) + pure service + groupBy (service ^. VersionRecordPkgId, service ^. VersionRecordNumber) + orderBy + [ asc (service ^. VersionRecordPkgId) + , desc (service ^. VersionRecordNumber) + , desc (service ^. VersionRecordUpdatedAt) + ] + pure service Nothing -> do - service <- from $ table @VersionRecord - where_ $ queryInMetadata query service + 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 - 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 = @@ -156,11 +187,20 @@ queryInMetadata query service = ||. (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 +getPkgDataSource :: (MonadResource m, MonadIO m) => [PkgId] -> Maybe OsArch -> ConduitT () (Entity VersionRecord) (ReaderT SqlBackend m) () +getPkgDataSource pkgs mOsArch = selectSource $ do + case mOsArch of + Just osArch -> do + (pkgData :& vp) <- from $ table @VersionRecord + `innerJoin` table @VersionPlatform `on` (\(service :& vp) -> (VersionPlatformPkgId === VersionRecordPkgId) (vp :& service)) + where_ (pkgData ^. VersionRecordNumber ==. vp ^. VersionPlatformVersionNumber) + where_ (vp ^. VersionPlatformArch ==. val osArch) + where_ (pkgData ^. VersionRecordPkgId `in_` valList (PkgRecordKey <$> pkgs)) + pure pkgData + Nothing -> do + pkgData <- from $ table @VersionRecord + where_ (pkgData ^. VersionRecordPkgId `in_` valList (PkgRecordKey <$> pkgs)) + pure pkgData getPkgDependencyData :: @@ -275,6 +315,20 @@ upsertPackageVersion PackageManifest{..} = do iconType packageManifestReleaseNotes packageManifestEosVersion - Nothing _res <- try @_ @SomeException $ insertKey pkgId (PkgRecord now (Just now)) repsert (VersionRecordKey pkgId packageManifestVersion) ins + +upsertPackageVersionPlatform :: (MonadUnliftIO m) => PackageManifest -> ReaderT SqlBackend m () +upsertPackageVersionPlatform PackageManifest{..} = do + now <- liftIO getCurrentTime + let pkgId = PkgRecordKey packageManifestId + let arches = [X86_64, AARCH64] + let records = createVersionPlatformRecord now pkgId packageManifestVersion <$> arches + repsertMany records + where + createVersionPlatformRecord time id version arch = ((VersionPlatformKey id version arch), VersionPlatform + time + (Just time) + id + version + arch) \ No newline at end of file diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 038e7f7..0eb4256 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -49,7 +49,7 @@ import Database.Persist ( (=.), ) import Database.Persist.Postgresql (runSqlPoolNoTransaction) -import Database.Queries (upsertPackageVersion) +import Database.Queries (upsertPackageVersion, upsertPackageVersionPlatform) import Foundation ( Handler, RegistryCtx (..), @@ -143,6 +143,7 @@ import Yesod ( ) import Yesod.Auth (YesodAuth (maybeAuthId)) import Yesod.Core.Types (JSONResponse (JSONResponse)) +import Database.Persist.Sql (runSqlPool) postPkgUploadR :: Handler () @@ -226,7 +227,7 @@ postPkgIndexR = do [i|Could not locate manifest for #{indexPkgReqId}@#{indexPkgReqVersion}|] pool <- getsYesod appConnPool runSqlPoolNoTransaction (upsertPackageVersion man) pool Nothing - + runSqlPool (upsertPackageVersionPlatform man) pool postPkgDeindexR :: Handler () postPkgDeindexR = do diff --git a/src/Handler/Eos/V0/Latest.hs b/src/Handler/Eos/V0/Latest.hs index 4cf4990..058e191 100644 --- a/src/Handler/Eos/V0/Latest.hs +++ b/src/Handler/Eos/V0/Latest.hs @@ -1,4 +1,5 @@ {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} module Handler.Eos.V0.Latest where @@ -11,17 +12,23 @@ import Database.Esqueleto.Experimental ( orderBy, select, table, + where_, + val, (^.), + (==.) ) -import Foundation (Handler) +import Foundation (Handler, RegistryCtx (appSettings)) import Handler.Package.V0.ReleaseNotes (ReleaseNotes (..)) -import Handler.Util (queryParamAs, tickleMAU) +import Handler.Util (queryParamAs, tickleMAU, getArchQuery) 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 Startlude (Bool (..), Down (..), Eq, Generic, Maybe (..), Ord ((<)), Show, Text, const, filter, fst, head, maybe, pure, sortOn, ($), (&&&), (.), (<$>), (<&>), (<=), (>>=)) +import Yesod (ToContent (toContent), ToTypedContent (..), YesodPersist (runDB), getsYesod, sendResponseStatus) import Yesod.Core.Types (JSONResponse (..)) +import Settings (AppSettings(maxEosVersion)) +import Network.HTTP.Types (status400) +import Lib.Error (S9Error(InvalidParamsE)) data EosRes = EosRes @@ -41,26 +48,39 @@ instance ToTypedContent EosRes where 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 - tickleMAU - pure . JSONResponse $ - mLatest <&> \latest -> - EosRes - { eosResVersion = osVersionNumber latest - , eosResHeadline = osVersionHeadline latest - , eosResReleaseNotes = mappedVersions - } + currentEosVersion <- queryParamAs "eos-version" parseVersion + getArchQuery >>= \case + Nothing -> sendResponseStatus status400 (InvalidParamsE "Param is required" "arch") + Just arch -> do + case currentEosVersion of + Nothing -> sendResponseStatus status400 (InvalidParamsE "Param is required" "eos-version") + Just currentEosVersion' -> do + maxVersion <- getsYesod $ maxEosVersion . appSettings + allEosVersions <- runDB $ + select $ do + vers <- from $ table @OsVersion + where_ (vers ^. OsVersionArch ==. val (Just arch)) + orderBy [desc (vers ^. OsVersionNumber)] + pure vers + let osV = determineMaxEosVersionAvailable maxVersion currentEosVersion' $ entityVal <$> allEosVersions + let mLatest = head osV + let mappedVersions = + ReleaseNotes $ + HM.fromList $ + sortOn (Down . fst) $ + filter (maybe (const True) (<) currentEosVersion . fst) $ + ((osVersionNumber &&& osVersionReleaseNotes)) + <$> osV + pure . JSONResponse $ + mLatest <&> \latest -> + EosRes + { eosResVersion = osVersionNumber latest + , eosResHeadline = osVersionHeadline latest + , eosResReleaseNotes = mappedVersions + } + +determineMaxEosVersionAvailable :: Version -> Version -> [OsVersion] -> [OsVersion] +determineMaxEosVersionAvailable maxEosVersion currentEosVersion versions = do + if (currentEosVersion < maxEosVersion) + then sortOn (Down . osVersionNumber) $ filter (\v -> osVersionNumber v <= maxEosVersion) $ versions + else versions \ No newline at end of file diff --git a/src/Handler/Package/V0/Info.hs b/src/Handler/Package/V0/Info.hs index 3717acf..7efcff3 100644 --- a/src/Handler/Package/V0/Info.hs +++ b/src/Handler/Package/V0/Info.hs @@ -10,7 +10,6 @@ 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] @@ -32,4 +31,4 @@ getInfoR = do orderBy [asc (cats ^. CategoryPriority)] pure cats tickleMAU - pure $ JSONResponse $ InfoRes name $ categoryName . entityVal <$> allCategories + pure $ JSONResponse $ InfoRes name (categoryName . entityVal <$> allCategories) diff --git a/src/Handler/Package/V0/Latest.hs b/src/Handler/Package/V0/Latest.hs index 9469ba9..102def0 100644 --- a/src/Handler/Package/V0/Latest.hs +++ b/src/Handler/Package/V0/Latest.hs @@ -18,6 +18,7 @@ import Model (VersionRecord (..)) import Network.HTTP.Types (status400) import Startlude (Bool (True), Down (Down), Either (..), Generic, Maybe (..), NonEmpty, Show, const, encodeUtf8, filter, flip, nonEmpty, pure, ($), (.), (<$>), (<&>)) import Yesod (ToContent (..), ToTypedContent (..), YesodPersist (runDB), YesodRequest (reqGetParams), getRequest, sendResponseStatus) +import Handler.Util (getArchQuery) newtype VersionLatestRes = VersionLatestRes (HashMap PkgId (Maybe Version)) @@ -36,30 +37,32 @@ getVersionLatestR = do getOsVersionQuery <&> \case Nothing -> const True Just v -> flip satisfies v - case lookup "ids" getParameters of - Nothing -> sendResponseStatus status400 (InvalidParamsE "get:ids" "") - Just packages -> case eitherDecode $ LBS.fromStrict $ encodeUtf8 packages of - Left _ -> sendResponseStatus status400 (InvalidParamsE "get:ids" packages) - Right p -> do - let packageList = (,Nothing) <$> p - let source = getPkgDataSource p - 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 - .| mapC (\(a, b) -> (a, (Just $ selectLatestVersion b))) - .| sinkList - -- if the requested package does not have available versions, return it as a key with a null value - pure $ - VersionLatestRes $ - HM.union (HM.fromList $ filteredPackages) (HM.fromList packageList) + osArch <- getArchQuery + do + case lookup "ids" getParameters of + Nothing -> sendResponseStatus status400 (InvalidParamsE "get:ids" "") + Just packages -> case eitherDecode $ LBS.fromStrict $ encodeUtf8 packages of + Left _ -> sendResponseStatus status400 (InvalidParamsE "get:ids" packages) + Right p -> do + let packageList = (,Nothing) <$> p + let source = getPkgDataSource p osArch + 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 + .| mapC (\(a, b) -> (a, (Just $ selectLatestVersion b))) + .| sinkList + -- if the requested package does not have available versions, return it as a key with a null value + pure $ + VersionLatestRes $ + HM.union (HM.fromList $ filteredPackages) (HM.fromList packageList) where selectLatestVersion :: NonEmpty VersionRecord -> Version selectLatestVersion vs = NE.head $ (versionRecordNumber <$>) $ NE.sortOn (Down . versionRecordNumber) $ vs diff --git a/src/Handler/Package/V1/Index.hs b/src/Handler/Package/V1/Index.hs index e3ef78d..ce39c1c 100644 --- a/src/Handler/Package/V1/Index.hs +++ b/src/Handler/Package/V1/Index.hs @@ -28,13 +28,11 @@ import Database.Queries ( import Foundation (Handler, Route (InstructionsR, LicenseR)) import Handler.Package.Api (DependencyRes (..), PackageListRes (..), PackageRes (..)) import Handler.Types.Api (ApiVersion (..)) -import Handler.Util (basicRender) -import Lib.Error (S9Error (..)) +import Handler.Util (basicRender, parseQueryParam, getArchQuery) 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 ( @@ -44,7 +42,6 @@ import Startlude ( ByteString, ConvertText (toS), Down (..), - Either (..), Eq (..), Int, Maybe (..), @@ -80,7 +77,6 @@ import Startlude ( (.*), (<$>), (<&>), - (<>), (=<<), ) import UnliftIO (Concurrently (..), mapConcurrently) @@ -90,10 +86,7 @@ import Yesod ( MonadResource, YesodPersist (runDB), lookupGetParam, - sendResponseStatus, ) -import Yesod.Core (logWarn) - data PackageReq = PackageReq { packageReqId :: !PkgId @@ -122,51 +115,40 @@ getPackageIndexR = do 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) + osArch <- getArchQuery + do + 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 osArch, const Any) + Just packages -> + let s = getPkgDataSource (packageReqId <$> packages) osArch + 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) getPkgIdsQuery :: Handler (Maybe [PackageReq]) getPkgIdsQuery = parseQueryParam "ids" (first toS . eitherDecodeStrict . encodeUtf8) diff --git a/src/Handler/Util.hs b/src/Handler/Util.hs index 949e94a..c57e2c9 100644 --- a/src/Handler/Util.hs +++ b/src/Handler/Util.hs @@ -1,4 +1,5 @@ {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} module Handler.Util where @@ -22,11 +23,11 @@ import Lib.PkgRepository ( PkgRepo, getHash, ) -import Lib.Types.Core (PkgId) +import Lib.Types.Core (PkgId, OsArch) import Lib.Types.Emver ( Version, VersionRange, - satisfies, + satisfies, parseVersion ) import Model ( UserActivity (..), @@ -60,7 +61,7 @@ import Startlude ( ($), (.), (<$>), - (>>=), + (>>=), note, (=<<) ) import UnliftIO (MonadUnliftIO) import Yesod ( @@ -76,8 +77,8 @@ import Yesod ( toContent, typePlain, ) -import Yesod.Core (addHeader) - +import Yesod.Core (addHeader, logWarn) +import Lib.Error (S9Error (..)) orThrow :: MonadHandler m => m (Maybe a) -> m a -> m a orThrow action other = @@ -111,7 +112,6 @@ getVersionFromQuery = do getHashFromQuery :: MonadHandler m => m (Maybe Text) getHashFromQuery = lookupGetParam "hash" - versionPriorityFromQueryIsMin :: MonadHandler m => m Bool versionPriorityFromQueryIsMin = do priorityString <- lookupGetParam "version-priority" @@ -140,14 +140,26 @@ queryParamAs k p = Left e -> sendResponseText status400 [i|Invalid Request! The query parameter '#{k}' failed to parse: #{e}|] Right a -> pure (Just a) +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) tickleMAU :: Handler () tickleMAU = do lookupGetParam "server-id" >>= \case Nothing -> pure () Just sid -> do + currentEosVersion <- queryParamAs "eos-version" parseVersion + arch <- getArchQuery now <- liftIO getCurrentTime - void $ liftHandler $ runDB $ insertRecord $ UserActivity now sid + void $ liftHandler $ runDB $ insertRecord $ UserActivity now sid currentEosVersion arch fetchCompatiblePkgVersions :: Maybe VersionRange -> PkgId -> Handler [VersionRecord] @@ -160,3 +172,6 @@ fetchCompatiblePkgVersions osVersion pkg = do case osV of Nothing -> const True Just v -> flip satisfies v + +getArchQuery :: Handler (Maybe OsArch) +getArchQuery = parseQueryParam "arch" ((flip $ note . mappend "Invalid 'arch': ") =<< readMaybe) \ No newline at end of file diff --git a/src/Lib/Types/Core.hs b/src/Lib/Types/Core.hs index fe563fa..db0092b 100644 --- a/src/Lib/Types/Core.hs +++ b/src/Lib/Types/Core.hs @@ -57,6 +57,7 @@ import Web.HttpApiData ( ToHttpApiData, ) import Yesod (PathPiece (..)) +import Prelude (read) newtype PkgId = PkgId {unPkgId :: Text} @@ -88,6 +89,27 @@ instance PathPiece PkgId where fromPathPiece = fmap PkgId . fromPathPiece toPathPiece = unPkgId +data OsArch = X86_64 | AARCH64 | RASPBERRYPI + deriving (Eq, Ord) +instance Show OsArch where + show X86_64 = "x86_64" + show AARCH64 = "aarch64" + show RASPBERRYPI = "raspberrypi" +instance Read OsArch where + readsPrec _ "x86_64" = [(X86_64, "")] + readsPrec _ "aarch64" = [(AARCH64, "")] + readsPrec _ "raspberrypi" = [(RASPBERRYPI, "")] + readsPrec _ _ = [] +instance PersistField OsArch where + toPersistValue = PersistText . show + fromPersistValue (PersistText t) = Right $ read $ toS t + fromPersistValue other = Left [i|Invalid OsArch: #{other}|] +instance PersistFieldSql OsArch where + sqlType _ = SqlString +instance FromJSON OsArch where + parseJSON = parseJSON +instance ToJSON OsArch where + toJSON = toJSON newtype Extension (a :: Symbol) = Extension String deriving (Eq) type S9PK = Extension "s9pk" diff --git a/src/Migration.hs b/src/Migration.hs index 50ea6d2..27438a3 100644 --- a/src/Migration.hs +++ b/src/Migration.hs @@ -17,7 +17,10 @@ import Startlude ( ($) ) manualMigration :: Migration -manualMigration = [(0, 1) := migration_0_2_0, (1, 2) := migration_0_2_1] +manualMigration = [(0, 1) := migration_0_2_0, (1, 2) := migration_0_2_1, (2, 3) := migration_0_2_2] + +migration_0_2_2 :: [Operation] +migration_0_2_2 = [DropColumn ("version", "arch")] migration_0_2_1 :: [Operation] migration_0_2_1 = [DropColumn ("category", "parent")] diff --git a/src/Model.hs b/src/Model.hs index f31e140..e1a8509 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -22,7 +22,7 @@ import Database.Persist.TH ( share, sqlSettings, ) -import Lib.Types.Core (PkgId (PkgId)) +import Lib.Types.Core (PkgId (PkgId), OsArch) import Lib.Types.Emver ( Version, VersionRange, @@ -60,17 +60,27 @@ VersionRecord sql=version iconType Text releaseNotes Text osVersion Version - arch Text Maybe Primary pkgId number deriving Eq deriving Show +VersionPlatform + createdAt UTCTime + updatedAt UTCTime Maybe + pkgId PkgRecordId + versionNumber Version + arch OsArch + Primary pkgId versionNumber arch + deriving Eq + deriving Show + OsVersion createdAt UTCTime updatedAt UTCTime number Version headline Text releaseNotes Text + arch OsArch Maybe deriving Eq deriving Show @@ -128,6 +138,8 @@ PkgDependency UserActivity createdAt UTCTime serverId Text + osVersion Version Maybe + arch OsArch Maybe Admin Id Text diff --git a/src/Settings.hs b/src/Settings.hs index bca3e71..b8278f0 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -62,29 +62,31 @@ import Orphans.Emver ( ) type AppPort = Word16 data AppSettings = AppSettings { appDatabaseConf :: !PostgresConf - , appHost :: !HostPreference - -- ^ Host/interface the server should bind to. - , appPort :: !AppPort - -- ^ Port to listen on - , appIpFromHeader :: !Bool - -- ^ Get the IP address from the header when logging. Useful when sitting - -- behind a reverse proxy. , appDetailedRequestLogging :: !Bool -- ^ Use detailed request logging system + , appHost :: !HostPreference + -- ^ Host/interface the server should bind to. + , appIpFromHeader :: !Bool + -- ^ Get the IP address from the header when logging. Useful when sitting + , appPort :: !AppPort + -- ^ Port to listen on + -- behind a reverse proxy. , appShouldLogAll :: !Bool -- ^ Should all log messages be displayed? - , resourcesDir :: !FilePath - , sslPath :: !FilePath - , sslAuto :: !Bool - , registryHostname :: !Text - , registryVersion :: !Version - , sslKeyLocation :: !FilePath - , sslCsrLocation :: !FilePath - , sslCertLocation :: !FilePath - , torPort :: !AppPort - , staticBinDir :: !FilePath , errorLogRoot :: !FilePath , marketplaceName :: !Text + , maxEosVersion :: !Version + , registryHostname :: !Text + , registryVersion :: !Version + , resourcesDir :: !FilePath + , needsMigration :: !Bool + , sslAuto :: !Bool + , sslCertLocation :: !FilePath + , sslCsrLocation :: !FilePath + , sslKeyLocation :: !FilePath + , sslPath :: !FilePath + , staticBinDir :: !FilePath + , torPort :: !AppPort } instance Has PkgRepo AppSettings where extract = liftA2 PkgRepo (( "apps") . resourcesDir) staticBinDir @@ -101,26 +103,27 @@ instance Has EosRepo AppSettings where instance FromJSON AppSettings where parseJSON = withObject "AppSettings" $ \o -> do appDatabaseConf <- o .: "database" - appHost <- fromString <$> o .: "host" - appPort <- o .: "port" - appIpFromHeader <- o .: "ip-from-header" appDetailedRequestLogging <- o .:? "detailed-logging" .!= True + appHost <- fromString <$> o .: "host" + appIpFromHeader <- o .: "ip-from-header" + appPort <- o .: "port" appShouldLogAll <- o .:? "should-log-all" .!= False - resourcesDir <- o .: "resources-path" - sslPath <- o .: "ssl-path" - sslAuto <- o .: "ssl-auto" - registryHostname <- o .: "registry-hostname" - torPort <- o .: "tor-port" - staticBinDir <- o .: "static-bin-dir" errorLogRoot <- o .: "error-log-root" + marketplaceName <- o .: "marketplace-name" + maxEosVersion <- o .: "max-eos-version" + registryHostname <- o .: "registry-hostname" + resourcesDir <- o .: "resources-path" + needsMigration <- o .: "run-migration" + sslAuto <- o .: "ssl-auto" + sslPath <- o .: "ssl-path" + staticBinDir <- o .: "static-bin-dir" + torPort <- o .: "tor-port" let sslKeyLocation = sslPath "key.pem" let sslCsrLocation = sslPath "certificate.csr" let sslCertLocation = sslPath "certificate.pem" let registryVersion = fromJust . parseMaybe parseJSON . String . toS . showVersion $ version - marketplaceName <- o .: "marketplace-name" - return AppSettings { .. } -- | Raw bytes at compile time of @config/settings.yml@