add ability to specify package architectures for publish script, as well as deindex them

package.yaml

@@ -63,6 +63,7 @@ dependencies:
   - unliftio
   - unordered-containers
   - unix
+  - utility-ht
   - wai
   - wai-cors
   - wai-extra

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 :: String -> String -> Version -> (Maybe [OsArch]) -> IO ()
-index name pkg v = performHttp name "POST" [i|/admin/v0/index|] (IndexPkgReq (PkgId $ toS pkg) v)
+index name pkg v arches = performHttp name "POST" [i|/admin/v0/index|] (IndexPkgReq (PkgId $ toS pkg) v arches)
 
 
-deindex :: String -> String -> Version -> IO ()
+deindex :: String -> String -> Version -> (Maybe [OsArch]) -> IO ()
-deindex name pkg v = performHttp name "POST" [i|/admin/v0/deindex|] (IndexPkgReq (PkgId $ toS pkg) v)
+deindex name pkg v arches = performHttp name "POST" [i|/admin/v0/deindex|] (IndexPkgReq (PkgId $ toS pkg) v arches)
 
 
 listUnindexed :: String -> IO ()

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 :: (MonadUnliftIO m) => (Maybe [OsArch]) -> PackageManifest -> ReaderT SqlBackend m ()
-upsertPackageVersionPlatform PackageManifest{..} = do
+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

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]}