diff --git a/.gitignore b/.gitignore index 65bca3c..258d189 100644 --- a/.gitignore +++ b/.gitignore @@ -30,6 +30,7 @@ version **/*.s9pk **/appmgr 0.3.0_features.md +**/start-sdk **/embassy-sdk start9-registry.prof start9-registry.hp @@ -39,4 +40,5 @@ start9-registry.ps shell.nix testdata/ lbuild.sh -icon \ No newline at end of file +icon +resources/apps/text-generation-webui \ No newline at end of file diff --git a/Makefile b/Makefile index 421c4fb..8b2d48f 100644 --- a/Makefile +++ b/Makefile @@ -5,4 +5,4 @@ profile: cabal: cabal build # this step is specific for m1 devices ie. aarch64-osx - sudo cp dist-newstyle/build/aarch64-osx/ghc-9.2.5/start9-registry-0.2.1/x/embassy-publish/build/embassy-publish/embassy-publish /usr/local/bin/ + sudo cp dist-newstyle/build/aarch64-osx/ghc-9.2.5/start9-registry-0.2.1/x/registry-publish/build/registry-publish/registry-publish /usr/local/bin/ diff --git a/README.md b/README.md index 71b90c0..6036b04 100644 --- a/README.md +++ b/README.md @@ -23,13 +23,13 @@ cd registry ``` - run `make` -### Set up embassy-publish tool +### Set up registry-publish tool - run `apt install libgmp-dev zlib1g-dev libtinfo-dev libpq-dev` (on macOS `brew install libmpd zlib-ng libtiff`) - run `stack install` (recommended: include the installation path in your $PATH after running this command) - update your shell to include the installation path of the copied executables from `stack install`. i.e. `nano ~./zshrc` add `export PATH=$PATH:/your/path/here` to zshrc; save and exit nano. Run `source ~/.zshrc` -- run `embassy-publish init --bash` (or --zsh / --fish depending on your preferred shell) -- run `embassy-publish reg add -l -n -u -p ` (include https:// in your URL) +- run `registry-publish init --bash` (or --zsh / --fish depending on your preferred shell) +- run `registry-publish reg add -l -n -u -p ` (include https:// in your URL) - take the hash that is emitted by this command and submit it to the registry owner ### Setting up a registry dev environment @@ -40,8 +40,8 @@ cd registry - set PG_PASSWORD to the password for that user - set SSL_AUTO to false - set RESOURCES_PATH to an empty directory you wish to use as your package repository -- install `embassy-sdk` -- set STATIC_BIN to the path that contains `embassy-sdk` +- install `start-sdk` +- set STATIC_BIN to the path that contains `start-sdk` ## APIs diff --git a/config/settings.yml b/config/settings.yml index d81150e..cc6a7e7 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -19,7 +19,7 @@ ip-from-header: "_env:YESOD_IP_FROM_HEADER:false" # In development, they default to the inverse. # detailed-logging: true -# should-log-all: false +# should-log-all: true # reload-templates: false # mutable-static: false # skip-combining: false diff --git a/hie.yaml b/hie.yaml index 0704f37..48ed33d 100644 --- a/hie.yaml +++ b/hie.yaml @@ -7,4 +7,4 @@ cradle: - path: "./test" component: "start9-registry:test:start9-registry-test" - path: "./cli" - component: "start9-registry:exe:embassy-publish" + component: "start9-registry:exe:registry-publish" diff --git a/package.yaml b/package.yaml index 193d575..52f6cfb 100644 --- a/package.yaml +++ b/package.yaml @@ -42,6 +42,7 @@ dependencies: - monad-logger - monad-logger-extras - monad-loops + - multimap - network-uri - optparse-applicative - parallel @@ -53,6 +54,8 @@ dependencies: - process - protolude - rainbow + - regex-base + - regex-tdfa - shakespeare - template-haskell - terminal-progress-bar @@ -63,6 +66,7 @@ dependencies: - unliftio - unordered-containers - unix + - utility-ht - wai - wai-cors - wai-extra @@ -107,7 +111,7 @@ executables: when: - condition: flag(library-only) buildable: false - embassy-publish: + registry-publish: source-dirs: cli main: Main.hs ghc-options: diff --git a/resources/apps/lnd/0.13.3.1/manifest.json b/resources/apps/lnd/0.13.3.1/manifest.json index 313f3b8..6624f29 100644 --- a/resources/apps/lnd/0.13.3.1/manifest.json +++ b/resources/apps/lnd/0.13.3.1/manifest.json @@ -16,6 +16,13 @@ "build": [ "make" ], + "hardware-requirements": { + "device": { + "processor": "intel", + "display": "r'^{.*}$'" + }, + "ram": "8" + }, "release-notes": "Upgrade to EmbassyOS v0.3.0", "license": "mit", "wrapper-repo": "https://github.com/Start9Labs/lnd-wrapper", diff --git a/src/Cli/Cli.hs b/src/Cli/Cli.hs index 6c06234..dfdc1bb 100644 --- a/src/Cli/Cli.hs +++ b/src/Cli/Cli.hs @@ -70,7 +70,7 @@ import Handler.Admin ( PackageList (..), ) import Lib.External.AppMgr (sourceManifest) -import Lib.Types.Core (PkgId (..)) +import Lib.Types.Core (PkgId (..), OsArch) import Lib.Types.Emver (Version (..)) import Lib.Types.Manifest (PackageManifest (..)) import Network.HTTP.Client.Conduit ( @@ -109,7 +109,6 @@ import Options.Applicative ( help, helper, info, - liftA3, long, mappend, metavar, @@ -205,12 +204,16 @@ import Yesod ( logError, logWarn, ) +import Prelude (read) +import Options.Applicative (some) +import Control.Applicative.HT (lift4) data Upload = Upload { publishRepoName :: !String , publishPkg :: !(Maybe FilePath) , publishIndex :: !Bool + , publishArches :: !(Maybe [OsArch]) } deriving (Show) @@ -253,7 +256,7 @@ data Command | CmdRegDel !String | CmdRegList | CmdUpload !Upload - | CmdIndex !String !String !Version !Bool + | CmdIndex !String !String !Version !(Maybe [OsArch]) !Bool | CmdListUnindexed !String | CmdCatAdd !String !String !(Maybe String) !(Maybe Int) | CmdCatDel !String !String @@ -267,7 +270,7 @@ cfgLocation = getHomeDirectory <&> \d -> d ".embassy/publish.dhall" parseInit :: Parser (Maybe Shell) -parseInit = subparser $ command "init" (info go $ progDesc "Initializes embassy-publish config") <> metavar "init" +parseInit = subparser $ command "init" (info go $ progDesc "Initializes registry-publish config") <> metavar "init" where shells = [Bash, Fish, Zsh] go = headMay . fmap fst . filter snd . zip shells <$> for shells (switch . long . toS . toLower . show) @@ -281,7 +284,7 @@ parsePublish = "upload" where go = - liftA3 + lift4 Upload (strOption (short 't' <> long "target" <> metavar "NAME" <> help "Name of registry in publish.dhall")) ( optional $ @@ -289,7 +292,17 @@ parsePublish = (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")) + ( optional $ + some parseArch + ) +parseArch :: Parser OsArch +parseArch = read <$> strOption + ( short 'a' + <> long "arches" + <> metavar "ARCHES" + <> help "Single element of package architectures type. Options include x86_64 and aarch64." + ) parseRepoAdd :: Parser Command parseRepoAdd = subparser $ command "add" (info go $ progDesc "Add a registry to your config") <> metavar "add" @@ -349,6 +362,7 @@ parseIndexHelper b = <$> strOption (short 't' <> long "target" <> metavar "REGISTRY_NAME") <*> strArgument (metavar "PKG") <*> strArgument (metavar "VERSION") + <*> optional (some parseArch) <*> pure b @@ -430,7 +444,7 @@ cliMain = 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 + CmdIndex name pkg v arches shouldIndex -> if shouldIndex then index name pkg v arches else deindex name pkg v arches CmdListUnindexed name -> listUnindexed name CmdCatAdd target cat desc pri -> catAdd target cat desc pri CmdCatDel target cat -> catDel target cat @@ -447,13 +461,13 @@ init sh = do for_ sh $ \case Bash -> do let bashrc = home ".bashrc" - appendFile bashrc "source <(embassy-publish --bash-completion-script `which embassy-publish`)\n" + appendFile bashrc "source <(registry-publish --bash-completion-script `which registry-publish`)\n" Fish -> do let fishrc = home ".config" "fish" "config.fish" - appendFile fishrc "source <(embassy-publish --fish-completion-script `which embassy-publish`)\n" + appendFile fishrc "source <(registry-publish --fish-completion-script `which registry-publish`)\n" Zsh -> do - let zshcompleter = "/usr/local/share/zsh/site-functions/_embassy-publish" - res <- readProcess "embassy-publish" ["--zsh-completion-script", "`which embassy-publish`"] "" + let zshcompleter = "/usr/local/share/zsh/site-functions/_registry-publish" + res <- readProcess "registry-publish" ["--zsh-completion-script", "`which registry-publish`"] "" writeFile zshcompleter (toS res) @@ -495,7 +509,7 @@ regLs = do upload :: Upload -> IO () -upload (Upload name mpkg shouldIndex) = do +upload (Upload name mpkg shouldIndex arches) = do PublishCfgRepo{..} <- findNameInCfg name pkg <- case mpkg of Nothing -> do @@ -515,7 +529,7 @@ upload (Upload name mpkg shouldIndex) = do noBody <- parseRequest ("POST " <> show publishCfgRepoLocation <> "/admin/v0/upload") <&> setRequestHeaders [("accept", "text/plain")] - <&> setRequestResponseTimeout (responseTimeoutMicro (600_000_000)) -- 10 minutes + <&> setRequestResponseTimeout (responseTimeoutMicro (5_400_000_000)) -- 90 minutes <&> applyBasicAuth (B8.pack publishCfgRepoUser) (B8.pack publishCfgRepoPass) size <- getFileSize pkg bar <- newProgressBar defStyle 30 (Progress 0 (fromIntegral size) ()) @@ -539,18 +553,18 @@ upload (Upload name mpkg shouldIndex) = do exitWith $ ExitFailure 1 Right a -> pure a let pkgId = toS $ unPkgId packageManifestId - index name pkgId packageManifestVersion + index name pkgId packageManifestVersion arches putChunkLn $ fromString ("Successfully indexed " <> pkgId <> "@" <> show packageManifestVersion) & fore green where sfs2prog :: StreamFileStatus -> Progress () 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) +index :: String -> String -> Version -> (Maybe [OsArch]) -> IO () +index name pkg v arches = performHttp name "POST" [i|/admin/v0/index|] (IndexPkgReq (PkgId $ toS pkg) v arches) -deindex :: String -> String -> Version -> IO () -deindex name pkg v = performHttp name "POST" [i|/admin/v0/deindex|] (IndexPkgReq (PkgId $ toS pkg) v) +deindex :: String -> String -> Version -> (Maybe [OsArch]) -> IO () +deindex name pkg v arches = performHttp name "POST" [i|/admin/v0/deindex|] (IndexPkgReq (PkgId $ toS pkg) v arches) listUnindexed :: String -> IO () diff --git a/src/Database/Queries.hs b/src/Database/Queries.hs index b0e83ec..7d47c13 100644 --- a/src/Database/Queries.hs +++ b/src/Database/Queries.hs @@ -11,7 +11,7 @@ import Database.Persist.Sql ( SqlBackend, ) import Lib.Types.Core ( - PkgId, OsArch (X86_64, AARCH64_NONFREE), + PkgId, OsArch (X86_64, AARCH64), ) import Lib.Types.Emver (Version) import Model ( @@ -31,7 +31,7 @@ import Startlude ( getCurrentTime, maybe, ($), - (.), Bool (False), + (.), Bool (False), fst, bimap, ) import System.FilePath (takeExtension) import UnliftIO ( @@ -55,7 +55,6 @@ import Database.Esqueleto.Experimental ( asc, desc, from, - groupBy, ilike, in_, innerJoin, @@ -97,7 +96,7 @@ import Model ( VersionRecordNumber, VersionRecordPkgId, VersionRecordTitle, - VersionRecordUpdatedAt, PkgRecordHidden + VersionRecordUpdatedAt, PkgRecordHidden, VersionPlatformRam ), Key (unPkgRecordKey), PkgCategory, @@ -114,77 +113,52 @@ import Startlude ( snd, sortOn, ($>), - (<$>), + (<$>), Int, ) +import Database.Esqueleto.Experimental (isNothing) +import Database.Esqueleto.Experimental ((<=.)) serviceQuerySource :: (MonadResource m, MonadIO m) => Maybe Text -> Text -> - Maybe OsArch -> - ConduitT () (Entity VersionRecord) (ReaderT SqlBackend m) () -serviceQuerySource mCat query mOsArch = selectSource $ do - case mOsArch of - Just osArch -> do - service <- case mCat of - Nothing -> do - (service :& vp :& pr) <- from $ table @VersionRecord - `innerJoin` table @VersionPlatform `on` (\(service :& vp) -> (VersionPlatformPkgId === VersionRecordPkgId) (vp :& service)) - `innerJoin` table @PkgRecord `on` (\(v :& _ :& p) -> (PkgRecordId === VersionRecordPkgId) (p :& v)) - where_ (service ^. VersionRecordNumber ==. vp ^. VersionPlatformVersionNumber) - where_ (vp ^. VersionPlatformArch ==. val osArch) - where_ (pr ^. PkgRecordHidden ==. val False) - where_ $ queryInMetadata query service - pure service - Just category -> do - (service :& _ :& cat :& vp :& pr) <- - 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)) - `innerJoin` table @PkgRecord `on` (\(v :& _ :& _ :& _ :& p) -> (PkgRecordId === VersionRecordPkgId) (p :& v)) - -- 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) - where_ (pr ^. PkgRecordHidden ==. val False) - pure service - groupBy (service ^. VersionRecordPkgId, service ^. VersionRecordNumber) - orderBy - [ asc (service ^. VersionRecordPkgId) - , desc (service ^. VersionRecordNumber) - , desc (service ^. VersionRecordUpdatedAt) - ] - pure service + [OsArch] -> + Maybe Int -> + ConduitT () (Entity VersionRecord, Entity VersionPlatform) (ReaderT SqlBackend m) () +serviceQuerySource mCat query arches mRam = selectSource $ do + (service, vp) <- case mCat of Nothing -> do - service <- case mCat of - Nothing -> do - (service :& pr) <- from $ table @VersionRecord - `innerJoin` table @PkgRecord `on` (\(v :& p) -> (PkgRecordId === VersionRecordPkgId) (p :& v)) - where_ $ queryInMetadata query service - where_ (pr ^. PkgRecordHidden ==. val False) - pure service - Just category -> do - (service :& _ :& cat :& pr) <- - from $ - table @VersionRecord - `innerJoin` table @PkgCategory `on` (VersionRecordPkgId === PkgCategoryPkgId) - `innerJoin` table @Category `on` (\(_ :& a :& b) -> (PkgCategoryCategoryId === CategoryId) (a :& b)) - `innerJoin` table @PkgRecord `on` (\(v :& _ :& _ :& p) -> (PkgRecordId === VersionRecordPkgId) (p :& v)) - -- 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_ (pr ^. PkgRecordHidden ==. val False) - pure service - groupBy (service ^. VersionRecordPkgId, service ^. VersionRecordNumber) - orderBy - [ asc (service ^. VersionRecordPkgId) - , desc (service ^. VersionRecordNumber) - , desc (service ^. VersionRecordUpdatedAt) - ] - pure service + (service :& vp :& pr) <- from $ table @VersionRecord + `innerJoin` table @VersionPlatform `on` (\(service :& vp) -> (VersionPlatformPkgId === VersionRecordPkgId) (vp :& service)) + `innerJoin` table @PkgRecord `on` (\(v :& _ :& p) -> (PkgRecordId === VersionRecordPkgId) (p :& v)) + where_ (service ^. VersionRecordNumber ==. vp ^. VersionPlatformVersionNumber) + where_ (vp ^. VersionPlatformArch `in_` (valList arches)) + where_ (vp ^. VersionPlatformRam <=. val mRam ||. isNothing (vp ^. VersionPlatformRam)) + where_ (pr ^. PkgRecordHidden ==. val False) + where_ $ queryInMetadata query service + pure (service, vp) + Just category -> do + (service :& _ :& cat :& vp :& pr) <- + 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)) + `innerJoin` table @PkgRecord `on` (\(v :& _ :& _ :& _ :& p) -> (PkgRecordId === VersionRecordPkgId) (p :& v)) + -- 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 `in_` (valList arches)) + where_ (vp ^. VersionPlatformRam <=. val mRam ||. isNothing (vp ^. VersionPlatformRam)) + where_ (pr ^. PkgRecordHidden ==. val False) + pure (service, vp) + orderBy + [ asc (service ^. VersionRecordPkgId) + , desc (service ^. VersionRecordNumber) + , desc (service ^. VersionRecordUpdatedAt) + ] + pure (service, vp) queryInMetadata :: Text -> SqlExpr (Entity VersionRecord) -> (SqlExpr (Value Bool)) queryInMetadata query service = @@ -193,20 +167,15 @@ queryInMetadata query service = ||. (service ^. VersionRecordTitle `ilike` (%) ++. val query ++. (%)) -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 +getPkgDataSource :: (MonadResource m, MonadIO m) => [PkgId] -> [OsArch] -> Maybe Int -> ConduitT () (Entity VersionRecord, Entity VersionPlatform) (ReaderT SqlBackend m) () +getPkgDataSource pkgs arches mRam = selectSource $ do + (pkgData :& vp) <- from $ table @VersionRecord + `innerJoin` table @VersionPlatform `on` (\(service :& vp) -> (VersionPlatformPkgId === VersionRecordPkgId) (vp :& service)) + where_ (pkgData ^. VersionRecordNumber ==. vp ^. VersionPlatformVersionNumber) + where_ (vp ^. VersionPlatformArch `in_` (valList arches)) + where_ (vp ^. VersionPlatformRam <=. val mRam ||. isNothing (vp ^. VersionPlatformRam)) + where_ (pkgData ^. VersionRecordPkgId `in_` valList (PkgRecordKey <$> pkgs)) + pure (pkgData, vp) getPkgDependencyData :: @@ -249,18 +218,18 @@ getCategoriesFor pkg = fmap (fmap entityVal) $ collateVersions :: MonadUnliftIO m => - ConduitT (Entity VersionRecord) (PkgId, [VersionRecord]) (ReaderT SqlBackend m) () -collateVersions = awaitForever $ \v0 -> do + ConduitT (Entity VersionRecord, Entity VersionPlatform) (PkgId, [(VersionRecord, VersionPlatform)]) (ReaderT SqlBackend m) () +collateVersions = awaitForever $ \(v0, vp) -> 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 + let pkg' = unPkgRecordKey . versionRecordPkgId $ entityVal $ fst vn if pkg == pkg' then pure (Just vn) else leftover vn $> Nothing ls <- unfoldM pull - yield (pkg, fmap entityVal $ v0 : ls) + yield (pkg, bimap entityVal entityVal (v0, vp) : fmap (\(v, vp') -> (entityVal v, entityVal vp')) ls) getDependencyVersions :: @@ -326,17 +295,36 @@ upsertPackageVersion PackageManifest{..} = do _res <- try @_ @SomeException $ insertKey pkgId (PkgRecord False now (Just now)) repsert (VersionRecordKey pkgId packageManifestVersion) ins -upsertPackageVersionPlatform :: (MonadUnliftIO m) => PackageManifest -> ReaderT SqlBackend m () -upsertPackageVersionPlatform PackageManifest{..} = do +upsertPackageVersionPlatform :: (MonadUnliftIO m) => (Maybe [OsArch]) -> PackageManifest -> ReaderT SqlBackend m () +upsertPackageVersionPlatform maybeArches PackageManifest{..} = do now <- liftIO getCurrentTime let pkgId = PkgRecordKey packageManifestId - let arches = [X86_64 .. AARCH64_NONFREE] - let records = createVersionPlatformRecord now pkgId packageManifestVersion <$> arches + let arches = case packageHardwareArch of + Just a -> a + Nothing -> case maybeArches of + Just a -> a + Nothing -> [X86_64, AARCH64] + let records = createVersionPlatformRecord now pkgId packageManifestVersion packageHardwareRam packageHardwareDevice <$> arches repsertMany records where - createVersionPlatformRecord time id version arch = ((VersionPlatformKey id version arch), VersionPlatform + createVersionPlatformRecord time id version ram device arch = ((VersionPlatformKey id version arch), VersionPlatform time (Just time) id version - arch) \ No newline at end of file + ram + device + arch) + +getVersionPlatform :: + (Monad m, MonadIO m) => + PkgRecordId -> + [OsArch] -> + ReaderT SqlBackend m [VersionPlatform] +getVersionPlatform pkgId arches = do + vps <- select $ do + v <- from $ table @VersionPlatform + where_ $ v ^. VersionPlatformPkgId ==. val pkgId + where_ (v ^. VersionPlatformArch `in_` (valList arches)) + pure v + pure $ entityVal <$> vps \ No newline at end of file diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 4855283..8c2003a 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -46,7 +46,7 @@ import Database.Persist ( entityVal, insert_, selectList, - (=.), + (=.), PersistQueryWrite (deleteWhere), ) import Database.Persist.Postgresql (runSqlPoolNoTransaction) import Database.Queries (upsertPackageVersion, upsertPackageVersionPlatform) @@ -67,12 +67,12 @@ import Lib.PkgRepository ( getPackages, getVersionsFor, ) -import Lib.Types.Core (PkgId (unPkgId)) +import Lib.Types.Core (PkgId (unPkgId), OsArch) import Lib.Types.Emver (Version (..)) import Lib.Types.Manifest (PackageManifest (..)) import Model ( Category (..), - EntityField (EosHashHash), + EntityField (EosHashHash, VersionPlatformArch, VersionPlatformVersionNumber, VersionPlatformPkgId), EosHash (EosHash), Key (AdminKey, PkgRecordKey, VersionRecordKey), PkgCategory (PkgCategory), @@ -119,7 +119,7 @@ import Startlude ( (>), (&&), (||), - (<=) + (<=), ) import System.FilePath ( (<.>), @@ -149,6 +149,7 @@ import Yesod.Auth (YesodAuth (maybeAuthId)) import Yesod.Core.Types (JSONResponse (JSONResponse)) import Database.Persist.Sql (runSqlPool) import Data.List (elem, length) +import Database.Persist ((==.)) postPkgUploadR :: Handler () postPkgUploadR = do @@ -213,12 +214,14 @@ postEosUploadR = do data IndexPkgReq = IndexPkgReq { indexPkgReqId :: !PkgId , indexPkgReqVersion :: !Version + , indexPkgReqArches :: !(Maybe [OsArch]) } deriving (Eq, Show) instance FromJSON IndexPkgReq where parseJSON = withObject "Index Package Request" $ \o -> do indexPkgReqId <- o .: "id" indexPkgReqVersion <- o .: "version" + indexPkgReqArches <- o .:? "arches" pure IndexPkgReq{..} instance ToJSON IndexPkgReq where toJSON IndexPkgReq{..} = object ["id" .= indexPkgReqId, "version" .= indexPkgReqVersion] @@ -232,15 +235,22 @@ postPkgIndexR = do liftIO (decodeFileStrict manifest) `orThrow` sendResponseText status404 - [i|Could not locate manifest for #{indexPkgReqId}@#{indexPkgReqVersion}|] + [i|Could not decode manifest for #{indexPkgReqId}@#{indexPkgReqVersion}|] pool <- getsYesod appConnPool runSqlPoolNoTransaction (upsertPackageVersion man) pool Nothing - runSqlPool (upsertPackageVersionPlatform man) pool + runSqlPool (upsertPackageVersionPlatform indexPkgReqArches man) pool postPkgDeindexR :: Handler () postPkgDeindexR = do IndexPkgReq{..} <- requireCheckJsonBody - runDB $ delete (VersionRecordKey (PkgRecordKey indexPkgReqId) indexPkgReqVersion) + case indexPkgReqArches of + Nothing -> runDB $ delete (VersionRecordKey (PkgRecordKey indexPkgReqId) indexPkgReqVersion) + Just a -> do + _ <- traverse (deleteArch indexPkgReqId indexPkgReqVersion) a + pure () + where + deleteArch :: PkgId -> Version -> OsArch -> Handler () + deleteArch id v a = runDB $ deleteWhere [VersionPlatformArch ==. a, VersionPlatformVersionNumber ==. v, VersionPlatformPkgId ==. PkgRecordKey id] newtype PackageList = PackageList {unPackageList :: HashMap PkgId [Version]} diff --git a/src/Handler/Eos/V0/Latest.hs b/src/Handler/Eos/V0/Latest.hs index 6543355..a2e171e 100644 --- a/src/Handler/Eos/V0/Latest.hs +++ b/src/Handler/Eos/V0/Latest.hs @@ -19,8 +19,8 @@ import Database.Esqueleto.Experimental ( ) import Foundation (Handler) import Handler.Package.V0.ReleaseNotes (ReleaseNotes (..)) -import Handler.Util (queryParamAs, getArchQuery) -import Lib.Types.Emver (Version (unVersion), Version(Version), parseVersion) +import Handler.Util (getOsArch, getOsVersion) +import Lib.Types.Emver (Version (unVersion), Version(Version)) import Model (EntityField (..), OsVersion (..)) import Orphans.Emver () import Startlude (Down (..), Eq, Generic, Maybe (..), Ord ((<)), Text, filter, fst, head, pure, sortOn, ($), (&&&), (.), (<$>), (<&>), (<=)) @@ -48,9 +48,9 @@ instance ToTypedContent EosRes where getEosVersionR :: Handler (JSONResponse (Maybe EosRes)) getEosVersionR = do - currentEosVersion <- fromMaybe Version { unVersion = (0,3,0,0) } <$> queryParamAs "eos-version" parseVersion + currentEosVersion <- fromMaybe Version { unVersion = (0,3,0,0) } <$> getOsVersion -- defaults to raspberrypi for those on OS versions where we did not send this param yet - arch <- fromMaybe RASPBERRYPI <$> getArchQuery + arch <- fromMaybe RASPBERRYPI <$> getOsArch allEosVersions <- runDB $ select $ do vers <- from $ table @OsVersion diff --git a/src/Handler/Package/V0/Icon.hs b/src/Handler/Package/V0/Icon.hs index 0f16584..01f0ad8 100644 --- a/src/Handler/Package/V0/Icon.hs +++ b/src/Handler/Package/V0/Icon.hs @@ -10,7 +10,7 @@ import Data.String.Interpolate.IsString ( i, ) import Foundation (Handler) -import Handler.Package.V1.Index (getOsVersionQuery) +import Handler.Package.V1.Index (getOsVersionCompat) import Handler.Util ( fetchCompatiblePkgVersions, getVersionSpecFromQuery, @@ -40,7 +40,7 @@ import Yesod ( getIconsR :: PkgId -> Handler TypedContent getIconsR pkg = do - osVersion <- getOsVersionQuery + osVersion <- getOsVersionCompat osCompatibleVersions <- fetchCompatiblePkgVersions osVersion pkg spec <- getVersionSpecFromQuery preferMin <- versionPriorityFromQueryIsMin diff --git a/src/Handler/Package/V0/Instructions.hs b/src/Handler/Package/V0/Instructions.hs index 0279c08..e066bca 100644 --- a/src/Handler/Package/V0/Instructions.hs +++ b/src/Handler/Package/V0/Instructions.hs @@ -10,7 +10,7 @@ import Data.String.Interpolate.IsString ( i, ) import Foundation (Handler) -import Handler.Package.V1.Index (getOsVersionQuery) +import Handler.Package.V1.Index (getOsVersionCompat) import Handler.Util ( fetchCompatiblePkgVersions, getVersionSpecFromQuery, @@ -42,7 +42,7 @@ import Yesod ( getInstructionsR :: PkgId -> Handler TypedContent getInstructionsR pkg = do spec <- getVersionSpecFromQuery - osVersion <- getOsVersionQuery + osVersion <- getOsVersionCompat osCompatibleVersions <- fetchCompatiblePkgVersions osVersion pkg preferMin <- versionPriorityFromQueryIsMin version <- diff --git a/src/Handler/Package/V0/Latest.hs b/src/Handler/Package/V0/Latest.hs index 83068a1..350763e 100644 --- a/src/Handler/Package/V0/Latest.hs +++ b/src/Handler/Package/V0/Latest.hs @@ -1,6 +1,6 @@ module Handler.Package.V0.Latest where -import Conduit (concatMapC, mapC, runConduit, sinkList, (.|)) +import Conduit (concatMapC, mapC, runConduit, sinkList, (.|), mapMC) import Data.Aeson (ToJSON (..), eitherDecode) import Data.ByteString.Lazy qualified as LBS import Data.HashMap.Strict (HashMap) @@ -10,15 +10,15 @@ import Data.List.NonEmpty.Extra qualified as NE import Data.Tuple.Extra (second) import Database.Queries (collateVersions, getPkgDataSource) import Foundation (Handler, RegistryCtx (appSettings)) -import Handler.Package.V1.Index (getOsVersionQuery) +import Handler.Package.V1.Index (getOsVersionCompat, getRamQuery, getHardwareDevicesQuery) import Lib.Error (S9Error (..)) import Lib.Types.Core (PkgId) import Lib.Types.Emver (Version (..), satisfies) 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 Startlude (Bool (True), Down (Down), Either (..), Generic, Maybe (..), NonEmpty, Show, const, encodeUtf8, filter, flip, nonEmpty, pure, ($), (.), (<$>), (<&>), fst) import Yesod (ToContent (..), ToTypedContent (..), YesodPersist (runDB), YesodRequest (reqGetParams), getRequest, sendResponseStatus) -import Handler.Util (getArchQuery, filterDeprecatedVersions) +import Handler.Util (filterDeprecatedVersions, getPkgArch, filterDevices) import Yesod.Core (getsYesod) import Settings (AppSettings(communityVersion)) @@ -36,10 +36,12 @@ getVersionLatestR :: Handler VersionLatestRes getVersionLatestR = do getParameters <- reqGetParams <$> getRequest osPredicate' <- - getOsVersionQuery <&> \case + getOsVersionCompat <&> \case Nothing -> const True Just v -> flip satisfies v - osArch <- getArchQuery + pkgArch <- getPkgArch + ram <- getRamQuery + hardwareDevices <- getHardwareDevicesQuery communityServiceDeprecationVersion <- getsYesod $ communityVersion . appSettings do case lookup "ids" getParameters of @@ -48,7 +50,7 @@ getVersionLatestR = do Left _ -> sendResponseStatus status400 (InvalidParamsE "get:ids" packages) Right p -> do let packageList = (,Nothing) <$> p - let source = getPkgDataSource p osArch + let source = getPkgDataSource p pkgArch ram filteredPackages <- runDB $ runConduit $ @@ -56,7 +58,12 @@ getVersionLatestR = do -- group conduit pipeline by pkg id .| collateVersions -- filter out versions of apps that are incompatible with the OS predicate - .| mapC (second (filter (osPredicate' . versionRecordOsVersion))) + .| mapC (second (filter (osPredicate' . versionRecordOsVersion . fst))) + -- filter hardware device compatability + .| mapMC (\(b,c) -> do + l <- filterDevices hardwareDevices c + pure (b, l) + ) -- filter out deprecated service versions after community registry release .| mapC (second (filterDeprecatedVersions communityServiceDeprecationVersion osPredicate')) -- prune empty version sets diff --git a/src/Handler/Package/V0/License.hs b/src/Handler/Package/V0/License.hs index 70645a5..9b366ee 100644 --- a/src/Handler/Package/V0/License.hs +++ b/src/Handler/Package/V0/License.hs @@ -10,7 +10,7 @@ import Data.String.Interpolate.IsString ( i, ) import Foundation (Handler) -import Handler.Package.V1.Index (getOsVersionQuery) +import Handler.Package.V1.Index (getOsVersionCompat) import Handler.Util ( fetchCompatiblePkgVersions, getVersionSpecFromQuery, @@ -41,7 +41,7 @@ import Yesod ( getLicenseR :: PkgId -> Handler TypedContent getLicenseR pkg = do - osVersion <- getOsVersionQuery + osVersion <- getOsVersionCompat osCompatibleVersions <- fetchCompatiblePkgVersions osVersion pkg spec <- getVersionSpecFromQuery preferMin <- versionPriorityFromQueryIsMin diff --git a/src/Handler/Package/V0/Manifest.hs b/src/Handler/Package/V0/Manifest.hs index f2dc965..ecb51cb 100644 --- a/src/Handler/Package/V0/Manifest.hs +++ b/src/Handler/Package/V0/Manifest.hs @@ -10,7 +10,7 @@ import Data.String.Interpolate.IsString ( i, ) import Foundation (Handler) -import Handler.Package.V1.Index (getOsVersionQuery) +import Handler.Package.V1.Index (getOsVersionCompat) import Handler.Util ( addPackageHeader, fetchCompatiblePkgVersions, @@ -42,7 +42,7 @@ import Yesod ( getAppManifestR :: PkgId -> Handler TypedContent getAppManifestR pkg = do - osVersion <- getOsVersionQuery + osVersion <- getOsVersionCompat osCompatibleVersions <- fetchCompatiblePkgVersions osVersion pkg versionSpec <- getVersionSpecFromQuery preferMin <- versionPriorityFromQueryIsMin diff --git a/src/Handler/Package/V0/ReleaseNotes.hs b/src/Handler/Package/V0/ReleaseNotes.hs index e823e8b..b107ccf 100644 --- a/src/Handler/Package/V0/ReleaseNotes.hs +++ b/src/Handler/Package/V0/ReleaseNotes.hs @@ -11,7 +11,7 @@ import Data.Aeson.Key (fromText) import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict qualified as HM import Foundation (Handler) -import Handler.Package.V1.Index (getOsVersionQuery) +import Handler.Package.V1.Index (getOsVersionCompat) import Handler.Util (fetchCompatiblePkgVersions) import Lib.Types.Core (PkgId) import Lib.Types.Emver (Version) @@ -49,7 +49,7 @@ instance ToTypedContent ReleaseNotes where getReleaseNotesR :: PkgId -> Handler ReleaseNotes getReleaseNotesR pkg = do - osVersion <- getOsVersionQuery + osVersion <- getOsVersionCompat osCompatibleVersions <- fetchCompatiblePkgVersions osVersion pkg pure $ constructReleaseNotesApiRes osCompatibleVersions where diff --git a/src/Handler/Package/V0/S9PK.hs b/src/Handler/Package/V0/S9PK.hs index 4ed12d5..8cc52d5 100644 --- a/src/Handler/Package/V0/S9PK.hs +++ b/src/Handler/Package/V0/S9PK.hs @@ -14,7 +14,7 @@ import Database.Queries ( ) import Foundation (Handler) import GHC.Show (show) -import Handler.Package.V1.Index (getOsVersionQuery) +import Handler.Package.V1.Index (getOsVersionCompat) import Handler.Util ( addPackageHeader, fetchCompatiblePkgVersions, @@ -79,7 +79,7 @@ getAppR file = do Nothing -> sendResponseStatus status416 ("Range Not Satisfiable" :: Text) Just ranges -> pure $ Just ranges let pkg = PkgId . T.pack $ takeBaseName (show file) - osVersion <- getOsVersionQuery + osVersion <- getOsVersionCompat osCompatibleVersions <- fetchCompatiblePkgVersions osVersion pkg versionSpec <- getVersionSpecFromQuery preferMin <- versionPriorityFromQueryIsMin diff --git a/src/Handler/Package/V0/Version.hs b/src/Handler/Package/V0/Version.hs index 5145832..f85b3fb 100644 --- a/src/Handler/Package/V0/Version.hs +++ b/src/Handler/Package/V0/Version.hs @@ -11,7 +11,7 @@ import Data.String.Interpolate.IsString ( i, ) import Foundation (Handler) -import Handler.Package.V1.Index (getOsVersionQuery) +import Handler.Package.V1.Index (getOsVersionCompat) import Handler.Util ( fetchCompatiblePkgVersions, getVersionSpecFromQuery, @@ -61,7 +61,7 @@ instance ToTypedContent (Maybe AppVersionRes) where getPkgVersionR :: PkgId -> Handler AppVersionRes getPkgVersionR pkg = do - osVersion <- getOsVersionQuery + osVersion <- getOsVersionCompat osCompatibleVersions <- fetchCompatiblePkgVersions osVersion pkg spec <- getVersionSpecFromQuery preferMin <- versionPriorityFromQueryIsMin diff --git a/src/Handler/Package/V1/Index.hs b/src/Handler/Package/V1/Index.hs index 317488c..ae5cec2 100644 --- a/src/Handler/Package/V1/Index.hs +++ b/src/Handler/Package/V1/Index.hs @@ -16,6 +16,7 @@ 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 qualified Data.MultiMap as MM import Database.Persist.Sql (SqlBackend) import Database.Queries ( collateVersions, @@ -28,7 +29,7 @@ import Database.Queries ( import Foundation (Handler, Route (InstructionsR, LicenseR), RegistryCtx (appSettings)) import Handler.Package.Api (DependencyRes (..), PackageListRes (..), PackageRes (..)) import Handler.Types.Api (ApiVersion (..)) -import Handler.Util (basicRender, parseQueryParam, getArchQuery, filterDeprecatedVersions) +import Handler.Util (basicRender, parseQueryParam, filterDeprecatedVersions, filterDevices, getPkgArch) import Lib.PkgRepository (PkgRepo, getIcon, getManifest) import Lib.Types.Core (PkgId) import Lib.Types.Emver (Version, VersionRange (..), parseRange, satisfies, (<||)) @@ -90,6 +91,10 @@ import Data.Tuple (fst) import Database.Persist.Postgresql (entityVal) import Yesod.Core (getsYesod) import Data.List (head) +import Yesod (YesodRequest(reqGetParams)) +import Yesod (getRequest) +import Data.List (last) +import Data.Text (isPrefixOf) data PackageReq = PackageReq { packageReqId :: !PkgId @@ -115,46 +120,52 @@ data PackageMetadata = PackageMetadata getPackageIndexR :: Handler PackageListRes getPackageIndexR = do osPredicate <- - getOsVersionQuery <&> \case + getOsVersionCompat <&> \case Nothing -> const True Just v -> flip satisfies v - osArch <- getArchQuery + pkgArch <- getPkgArch + ram <- getRamQuery + hardwareDevices <- getHardwareDevicesQuery communityVersion <- getsYesod $ communityVersion . appSettings - 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))) - -- filter out deprecated service versions after community registry release - .| mapC (second (filterDeprecatedVersions communityVersion osPredicate)) - -- 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 + 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 pkgArch ram, const Any) + Just packages -> + let s = getPkgDataSource (packageReqId <$> packages) pkgArch ram + 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 . fst))) + -- filter hardware device compatability + .| mapMC (\(b,c) -> do + l <- filterDevices hardwareDevices c + pure (b, l) + ) + -- filter out deprecated service versions after community registry release + .| mapC (second (filterDeprecatedVersions communityVersion osPredicate)) + -- 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) + -- 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) @@ -172,9 +183,29 @@ 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) +getOsVersionCompatQueryLegacy :: Handler (Maybe VersionRange) +getOsVersionCompatQueryLegacy = parseQueryParam "eos-version-compat" (first toS . Atto.parseOnly parseRange) +getOsVersionCompatQuery :: Handler (Maybe VersionRange) +getOsVersionCompatQuery = parseQueryParam "os.compat" (first toS . Atto.parseOnly parseRange) + +getOsVersionCompat :: Handler (Maybe VersionRange) +getOsVersionCompat = do + osVersion <- getOsVersionCompatQuery >>= \case + Just a -> pure $ Just a + Nothing -> getOsVersionCompatQueryLegacy + pure osVersion + +getHardwareDevicesQuery :: Handler (MM.MultiMap Text Text) +getHardwareDevicesQuery = do + allParams <- reqGetParams <$> getRequest + -- [("hardware.device.processor","intel"),("hardware.device.display","led")] + let hardwareDeviceParams = filter (\(key, _) -> "hardware.device" `isPrefixOf` key) allParams + -- [("processor","intel"),("display","led")] + pure $ MM.fromList $ first (last . T.splitOn ".") <$> hardwareDeviceParams + +getRamQuery :: Handler (Maybe Int) +getRamQuery = parseQueryParam "hardware.ram" ((flip $ note . mappend "Invalid 'ram': ") =<< readMaybe) getPackageDependencies :: (MonadIO m, MonadLogger m, MonadResource m, Has PkgRepo r, MonadReader r m) => diff --git a/src/Handler/Util.hs b/src/Handler/Util.hs index 4708c4c..b96cd7d 100644 --- a/src/Handler/Util.hs +++ b/src/Handler/Util.hs @@ -1,5 +1,6 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} module Handler.Util where @@ -17,13 +18,13 @@ import Data.String.Interpolate.IsString ( import Data.Text qualified as T import Data.Text.Lazy qualified as TL import Data.Text.Lazy.Builder qualified as TB -import Database.Queries (fetchAllPkgVersions) +import Database.Queries (fetchAllPkgVersions, getVersionPlatform) import Foundation import Lib.PkgRepository ( PkgRepo, getHash, ) -import Lib.Types.Core (PkgId, OsArch) +import Lib.Types.Core (PkgId, OsArch (..)) import Lib.Types.Emver ( Version, VersionRange, @@ -31,7 +32,7 @@ import Lib.Types.Emver ( ) import Model ( UserActivity (..), - VersionRecord (versionRecordOsVersion, versionRecordDeprecatedAt), + VersionRecord (versionRecordOsVersion, versionRecordDeprecatedAt, versionRecordPkgId), VersionPlatform (versionPlatformDevice), ) import Network.HTTP.Types ( Status, @@ -61,7 +62,7 @@ import Startlude ( ($), (.), (<$>), - (>>=), note, (=<<) + (>>=), note, (=<<), catMaybes, all, encodeUtf8, toS, fmap, traceM, show, trace, any, or, (++), IO, putStrLn, map ) import UnliftIO (MonadUnliftIO) import Yesod ( @@ -80,6 +81,13 @@ import Yesod ( import Yesod.Core (addHeader, logWarn) import Lib.Error (S9Error (..)) import Data.Maybe (isJust) +import qualified Data.HashMap.Strict as HM +import Lib.Types.Manifest +import Text.Regex.TDFA ((=~)) +import Data.Aeson (eitherDecodeStrict) +import Data.Bifunctor (Bifunctor(first)) +import qualified Data.MultiMap as MM +import Startlude (bimap) orThrow :: MonadHandler m => m (Maybe a) -> m a -> m a orThrow action other = @@ -158,7 +166,7 @@ tickleMAU = do Nothing -> pure () Just sid -> do currentEosVersion <- queryParamAs "eos-version" parseVersion - arch <- getArchQuery + arch <- getOsArch now <- liftIO getCurrentTime void $ liftHandler $ runDB $ insertRecord $ UserActivity now sid currentEosVersion arch @@ -174,11 +182,74 @@ fetchCompatiblePkgVersions osVersion pkg = do Nothing -> const True Just v -> flip satisfies v -getArchQuery :: Handler (Maybe OsArch) -getArchQuery = parseQueryParam "arch" ((flip $ note . mappend "Invalid 'arch': ") =<< readMaybe) +getOsArchQueryLegacy :: Handler (Maybe OsArch) +getOsArchQueryLegacy = parseQueryParam "arch" ((flip $ note . mappend "Invalid 'arch': ") =<< readMaybe) + +getOsArchQuery :: Handler (Maybe OsArch) +getOsArchQuery = parseQueryParam "os.arch" ((flip $ note . mappend "Invalid 'arch': ") =<< readMaybe) + +getOsArch :: Handler (Maybe OsArch) +getOsArch = do + osArch <- getOsArchQuery >>= \case + Just a -> pure $ Just a + Nothing -> getOsArchQueryLegacy + pure osArch + +getOsVersionLegacy :: Handler (Maybe Version) +getOsVersionLegacy = parseQueryParam "eos-version" ((flip $ note . mappend "Invalid 'eos-version': ") =<< readMaybe) + +getOsVersionQuery :: Handler (Maybe Version) +getOsVersionQuery = parseQueryParam "os.version" ((flip $ note . mappend "Invalid 'os.version': ") =<< readMaybe) + +getOsVersion :: Handler (Maybe Version) +getOsVersion = do + osVersion <- getOsVersionQuery >>= \case + Just a -> pure $ Just a + Nothing -> getOsVersionLegacy + pure osVersion + +getPkgArch :: Handler [OsArch] +getPkgArch = do + arch <- parseQueryParam "hardware.arch" ((flip $ note . mappend "Invalid 'hardware.arch': ") =<< readMaybe) + case arch of + Just a -> pure [a] + Nothing -> do + getOsArch >>= \case + Just a -> pure [matchLegacyArch a] + Nothing -> pure [X86_64, AARCH64] + where + matchLegacyArch X86_64 = X86_64 + matchLegacyArch AARCH64 = AARCH64 + matchLegacyArch RASPBERRYPI = AARCH64 + matchLegacyArch X86_64_NONFREE = X86_64 + matchLegacyArch AARCH64_NONFREE = AARCH64 filterDeprecatedVersions :: Version -> (Version -> Bool) -> [VersionRecord] -> [VersionRecord] filterDeprecatedVersions communityVersion osPredicate vrs = do if (osPredicate communityVersion) then filter (\v -> not $ isJust $ versionRecordDeprecatedAt v) $ vrs - else vrs \ No newline at end of file + else vrs + +filterDevices :: (MonadUnliftIO m) => (MM.MultiMap Text Text) -> [(VersionRecord, VersionPlatform)] -> m [VersionRecord] +filterDevices hardwareDevices pkgRecords = do + pure $ catMaybes $ fmap (compareHd hardwareDevices) pkgRecords + where + compareHd :: MM.MultiMap Text Text -> (VersionRecord, VersionPlatform) -> Maybe VersionRecord + compareHd hd (vr, vp) = case versionPlatformDevice vp of + Nothing -> do + Just vr + Just d -> if areRegexMatchesEqual hd d + then Just vr + else Nothing + +regexMatch :: RegexPattern -> Text -> Bool +regexMatch (RegexPattern pattern) text = text =~ pattern + +areRegexMatchesEqual :: MM.MultiMap Text Text -> PackageDevice -> Bool +areRegexMatchesEqual textMap (PackageDevice regexMap) = + any checkMatch (HM.toList regexMap) + where + checkMatch :: (Text, RegexPattern) -> Bool + checkMatch (key, regexPattern) = + case MM.lookup key textMap of + val -> or $ regexMatch regexPattern <$> val \ No newline at end of file diff --git a/src/Lib/External/AppMgr.hs b/src/Lib/External/AppMgr.hs index 4caa398..ab9c83a 100644 --- a/src/Lib/External/AppMgr.hs +++ b/src/Lib/External/AppMgr.hs @@ -105,23 +105,23 @@ sourceManifest :: (ConduitT () ByteString m () -> m r) -> m r sourceManifest appmgrPath pkgFile sink = do - let appmgr = readProcessInheritStderr (appmgrPath "embassy-sdk") ["inspect", "manifest", pkgFile] "" + let appmgr = readProcessInheritStderr (appmgrPath "start-sdk") ["inspect", "manifest", pkgFile] "" appmgr sink `catch` \ece -> - $logErrorSH ece *> throwIO (AppMgrE [i|embassy-sdk inspect manifest #{pkgFile}|] (eceExitCode ece)) + $logErrorSH ece *> throwIO (AppMgrE [i|start-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] "" + let appmgr = readProcessInheritStderr (appmgrPath "start-sdk") ["inspect", "icon", pkgFile] "" appmgr sink `catch` \ece -> - $logErrorSH ece *> throwIO (AppMgrE [i|embassy-sdk inspect icon #{pkgFile}|] (eceExitCode ece)) + $logErrorSH ece *> throwIO (AppMgrE [i|start-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] "" + let appmgr = readProcessInheritStderr (appmgrPath "start-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)) + $logErrorSH ece *> throwIO (AppMgrE [i|start-sdk inspect hash #{pkgFile}|] (eceExitCode ece)) sourceInstructions :: @@ -131,9 +131,9 @@ sourceInstructions :: (ConduitT () ByteString m () -> m r) -> m r sourceInstructions appmgrPath pkgFile sink = do - let appmgr = readProcessInheritStderr (appmgrPath "embassy-sdk") ["inspect", "instructions", pkgFile] "" + let appmgr = readProcessInheritStderr (appmgrPath "start-sdk") ["inspect", "instructions", pkgFile] "" appmgr sink `catch` \ece -> - $logErrorSH ece *> throwIO (AppMgrE [i|embassy-sdk inspect instructions #{pkgFile}|] (eceExitCode ece)) + $logErrorSH ece *> throwIO (AppMgrE [i|start-sdk inspect instructions #{pkgFile}|] (eceExitCode ece)) sourceLicense :: @@ -143,6 +143,6 @@ sourceLicense :: (ConduitT () ByteString m () -> m r) -> m r sourceLicense appmgrPath pkgFile sink = do - let appmgr = readProcessInheritStderr (appmgrPath "embassy-sdk") ["inspect", "license", pkgFile] "" + let appmgr = readProcessInheritStderr (appmgrPath "start-sdk") ["inspect", "license", pkgFile] "" appmgr sink `catch` \ece -> - $logErrorSH ece *> throwIO (AppMgrE [i|embassy-sdk inspect license #{pkgFile}|] (eceExitCode ece)) + $logErrorSH ece *> throwIO (AppMgrE [i|start-sdk inspect license #{pkgFile}|] (eceExitCode ece)) diff --git a/src/Lib/Types/Core.hs b/src/Lib/Types/Core.hs index 9bb2271..10474fa 100644 --- a/src/Lib/Types/Core.hs +++ b/src/Lib/Types/Core.hs @@ -27,7 +27,7 @@ import Startlude ( show, symbolVal, ($), - (.), Enum, + (.), Enum, Applicative (..), ) import Data.Aeson ( @@ -57,8 +57,8 @@ import Web.HttpApiData ( ToHttpApiData, ) import Yesod (PathPiece (..)) -import Prelude (read) - +import Prelude (read, fail) +import Data.Aeson.Types (withText) newtype PkgId = PkgId {unPkgId :: Text} deriving stock (Eq, Ord) @@ -112,7 +112,14 @@ instance PersistField OsArch where instance PersistFieldSql OsArch where sqlType _ = SqlString instance FromJSON OsArch where - parseJSON = parseJSON + parseJSON = withText "OsArch" $ \case + "x86_64" -> pure X86_64 + "aarch64" -> pure AARCH64 + "raspberrypi" -> pure RASPBERRYPI + "rasberrypi" -> pure RASPBERRYPI + "x86_64-nonfree" -> pure X86_64_NONFREE + "arch64-nonfree"-> pure AARCH64_NONFREE + _ -> fail "Invalid OsArch value" instance ToJSON OsArch where toJSON = toJSON diff --git a/src/Lib/Types/Emver.hs b/src/Lib/Types/Emver.hs index 9353557..7c7c0f4 100644 --- a/src/Lib/Types/Emver.hs +++ b/src/Lib/Types/Emver.hs @@ -73,7 +73,7 @@ import Startlude ( ($) ) import Control.Monad.Fail ( fail ) -import Data.Aeson ( ToJSONKey ) +import Data.Aeson ( ToJSONKey, toJSON, Value(String)) import qualified Data.Attoparsec.Text as Atto import qualified Data.Text as T import GHC.Base ( error ) @@ -81,9 +81,13 @@ import qualified GHC.Read as GHC ( readsPrec ) import qualified GHC.Show as GHC ( show ) +import Dhall (Generic) +import Data.Aeson.Types (ToJSON) -- | AppVersion is the core representation of the SemverQuad type. -newtype Version = Version { unVersion :: (Word, Word, Word, Word) } deriving (Eq, Ord, ToJSONKey, Hashable) +newtype Version = Version { unVersion :: (Word, Word, Word, Word) } deriving (Eq, Ord, Generic, ToJSONKey, Hashable) +instance ToJSON Version where + toJSON = String . show instance Show Version where show (Version (x, y, z, q)) = let postfix = if q == 0 then "" else '.' : GHC.show q diff --git a/src/Lib/Types/Manifest.hs b/src/Lib/Types/Manifest.hs index dc45c5c..ecd3ff4 100644 --- a/src/Lib/Types/Manifest.hs +++ b/src/Lib/Types/Manifest.hs @@ -5,14 +5,30 @@ 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.Core (PkgId, OsArch) import Lib.Types.Emver (Version (..), VersionRange) -import Startlude (ByteString, Eq, Generic, Hashable, Maybe (..), Monad ((>>=)), Read, Show, Text, for, pure, readMaybe, ($)) +import Startlude (ByteString, Eq, Generic, Hashable, Maybe (..), Monad ((>>=)), Read, Show, Text, for, pure, readMaybe, ($), Int, (.), fmap, String, null, (<$>), otherwise) +import Data.Aeson + ( eitherDecodeStrict, + (.:), + (.:?), + withObject, + withText, + FromJSON(parseJSON), + ToJSON(toJSON), encode ) +import Database.Persist.Sql ( PersistFieldSql(..) ) +import Database.Persist.Types (SqlType(..)) +import Database.Persist (PersistValue(..)) +import Data.Either (Either(..)) +import Database.Persist.Class ( PersistField(..) ) +import Data.Maybe (maybe) +import qualified Data.ByteString as BS +import Yesod.Persist (LiteralType(Escaped)) +import Data.Aeson.Types (Value(Object), Parser) data PackageManifest = PackageManifest @@ -26,6 +42,9 @@ data PackageManifest = PackageManifest , packageManifestAlerts :: !(HashMap ServiceAlert (Maybe Text)) , packageManifestDependencies :: !(HashMap PkgId PackageDependency) , packageManifestEosVersion :: !Version + , packageHardwareDevice :: !(Maybe PackageDevice) + , packageHardwareRam :: !(Maybe Int) + , packageHardwareArch :: !(Maybe [OsArch]) } deriving (Show) instance FromJSON PackageManifest where @@ -47,8 +66,16 @@ instance FromJSON PackageManifest where let packageManifestAlerts = HM.fromList a packageManifestDependencies <- o .: "dependencies" packageManifestEosVersion <- o .: "eos-version" + packageHardwareDevice <- o .:? "hardware-requirements" >>= maybe (pure Nothing) (.:? "devices") >>= parsePackageDevice + packageHardwareRam <- o .:? "hardware-requirements" >>= maybe (pure Nothing) (.:? "ram") + packageHardwareArch <- o .:? "hardware-requirements" >>= maybe (pure Nothing) (.:? "arch") pure PackageManifest{..} +parsePackageDevice :: Maybe Value -> Parser (Maybe PackageDevice) +parsePackageDevice (Just (Object o)) + | null o = pure Nothing + | otherwise = Just . PackageDevice <$> parseJSON (Object o) +parsePackageDevice _ = pure Nothing data PackageDependency = PackageDependency { packageDependencyOptional :: !(Maybe Text) @@ -63,22 +90,57 @@ instance FromJSON PackageDependency where packageDependencyDescription <- o .:? "description" pure PackageDependency{..} +-- Custom type for regex pattern +newtype RegexPattern = RegexPattern Text + deriving (Show, Eq, Generic) +instance FromJSON RegexPattern where + parseJSON = withText "RegexPattern" (pure . RegexPattern) +instance ToJSON RegexPattern where + toJSON (RegexPattern txt) = toJSON txt + +newtype PackageDevice = PackageDevice { unPackageDevice :: HashMap Text RegexPattern } + deriving (Show, Eq, Generic) + +instance FromJSON PackageDevice where + parseJSON = fmap PackageDevice . parseJSON +instance ToJSON PackageDevice where + toJSON = toJSON . unPackageDevice + +instance PersistField PackageDevice where + toPersistValue = PersistLiteral_ Escaped . BS.toStrict . encode + fromPersistValue (PersistByteString t) = case eitherDecodeStrict t of + Left err -> Left $ T.pack err + Right val -> Right val + fromPersistValue _ = Left "Invalid JSON value in database ERR" + +instance PersistFieldSql PackageDevice where + sqlType _ = SqlOther "JSONB" data ServiceAlert = INSTALL | UNINSTALL | RESTORE | START | STOP deriving (Show, Eq, Generic, Hashable, Read) --- >>> eitherDecode testManifest :: Either String PackageManifest +-- >>> eitherDecodeStrict testManifest :: Either String PackageManifest +-- Right (PackageManifest {packageManifestId = embassy-pages, packageManifestTitle = "Embassy Pages", packageManifestVersion = 0.1.3, packageManifestDescriptionLong = "Embassy Pages is a simple web server that uses directories inside File Browser to serve Tor websites.", packageManifestDescriptionShort = "Create Tor websites, hosted on your Embassy.", packageManifestReleaseNotes = "Upgrade to EmbassyOS v0.3.0", packageManifestIcon = Just "icon.png", packageManifestAlerts = fromList [(STOP,Nothing),(RESTORE,Nothing),(INSTALL,Nothing),(START,Nothing),(UNINSTALL,Nothing)], packageManifestDependencies = fromList [(filebrowser,PackageDependency {packageDependencyOptional = Nothing, packageDependencyVersion = >=2.14.1.1 <3.0.0, packageDependencyDescription = Just "Used to upload files to serve."})], packageManifestEosVersion = 0.3.0, packageHardwareDevice = Just (PackageDevice (fromList [("processor",RegexPattern "^[A-Za-z0-9]+$"),("display",RegexPattern "^[A-Za-z0-9]+$")])), packageHardwareRam = Just 8000000000, packageHardwareArch = Just [aarch64,x86_64]}) testManifest :: ByteString testManifest = [i|{ "id": "embassy-pages", "title": "Embassy Pages", "version": "0.1.3", + "eos-version": "0.3.0", "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." }, + "hardware-requirements": { + "device": { + "processor": "^[A-Za-z0-9]+$", + "display": "^[A-Za-z0-9]+$" + }, + "ram": 8000000000, + "arch": ["aarch64", "x86_64"] + }, "assets": { "license": "LICENSE", "icon": "icon.png", @@ -208,4 +270,4 @@ testManifest = "config": null } } -}|] \ No newline at end of file +}|] diff --git a/src/Model.hs b/src/Model.hs index 1160fe4..a7b1566 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -36,8 +36,9 @@ import Startlude ( Text, UTCTime, Word32, - Bool + Bool, ) +import Lib.Types.Manifest (PackageDevice) share @@ -72,6 +73,8 @@ VersionPlatform updatedAt UTCTime Maybe pkgId PkgRecordId versionNumber Version + ram Int Maybe + device PackageDevice Maybe arch OsArch Primary pkgId versionNumber arch deriving Eq diff --git a/src/Orphans/Emver.hs b/src/Orphans/Emver.hs index 6c0c5c2..7a4ce20 100644 --- a/src/Orphans/Emver.hs +++ b/src/Orphans/Emver.hs @@ -35,8 +35,6 @@ import Lib.Types.Emver ( Version instance FromJSON Version where parseJSON = withText "Emver Version" $ either fail pure . Atto.parseOnly parseVersion -instance ToJSON Version where - toJSON = String . show instance FromJSON VersionRange where parseJSON = withText "Emver" $ either fail pure . Atto.parseOnly parseRange instance ToJSON VersionRange where