diff --git a/package.yaml b/package.yaml index 193d575..cd21fea 100644 --- a/package.yaml +++ b/package.yaml @@ -63,6 +63,7 @@ dependencies: - unliftio - unordered-containers - unix + - utility-ht - wai - wai-cors - wai-extra diff --git a/src/Cli/Cli.hs b/src/Cli/Cli.hs index 6c06234..341206c 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 @@ -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 @@ -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 @@ -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..8e8b32e 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 ( @@ -326,11 +326,13 @@ 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 arches = case maybeArches of + Just a -> a + Nothing -> [X86_64 .. AARCH64] let records = createVersionPlatformRecord now pkgId packageManifestVersion <$> arches repsertMany records where diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 4855283..1a7c4f0 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), @@ -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] @@ -235,12 +238,19 @@ postPkgIndexR = do [i|Could not locate 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]}