Update/eos 033 (#128)

* add marketplace icon to info response

* fix max eos version available logic; toggle migrations

* only send icon if it exists

* increase upload timeout

* persist eos version and arch for user activity

* filter eos versions available based on arch

* remove registry icon

* remove eos upload from publish script

* filter package index response by arch

* remove arch from version record in favor of join table

* allow previous user activity records to contain null values

* make arch optional for backwards compatability

* make arch optional for backwards compatability on version latest endpoint

* not ideal but functional solution for backwards compatible arch filter

* insert version platform when index on publish upload

* add migration for dropping arch from package version table

* upsert all version platform records

* insert user activity even if version and arch do not exist

* increase http timeout to 10 minutes jic

* remove user metrics from latest endpoint

.gitignore

@@ -39,3 +39,4 @@ start9-registry.ps
 shell.nix
 testdata/
 lbuild.sh
+icon

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"

src/Application.hs

@@ -254,9 +254,12 @@ makeFoundation appSettings = do
         flip runLoggingT logFunc $
             createPostgresqlPool (pgConnStr $ appDatabaseConf appSettings) (pgPoolSize . appDatabaseConf $ appSettings)
 
+    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
 

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)
 

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,8 +123,40 @@ serviceQuerySource ::
     (MonadResource m, MonadIO m) =>
     Maybe Text ->
     Text ->
+    Maybe OsArch ->
     ConduitT () (Entity VersionRecord) (ReaderT SqlBackend m) ()
-serviceQuerySource mCat query = selectSource $ do
+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 <- case mCat of
                 Nothing -> do
                     service <- from $ table @VersionRecord 
@@ -148,7 +180,6 @@ serviceQuerySource mCat query = selectSource $ do
                 ]
             pure service
 
-
 queryInMetadata :: Text -> SqlExpr (Entity VersionRecord) -> (SqlExpr (Value Bool))
 queryInMetadata query service =
     (service ^. VersionRecordDescShort `ilike` (%) ++. val query ++. (%))
@@ -156,8 +187,17 @@ queryInMetadata query service =
         ||. (service ^. VersionRecordTitle `ilike` (%) ++. val query ++. (%))
 
 
-getPkgDataSource :: (MonadResource m, MonadIO m) => [PkgId] -> ConduitT () (Entity VersionRecord) (ReaderT SqlBackend m) ()
+getPkgDataSource :: (MonadResource m, MonadIO m) => [PkgId] -> Maybe OsArch -> ConduitT () (Entity VersionRecord) (ReaderT SqlBackend m) ()
-getPkgDataSource pkgs = selectSource $ do
+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
@@ -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)

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

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 Startlude (Bool (..), Down (..), Eq, Generic, Maybe (..), Ord ((<)), Show, Text, const, filter, fst, head, maybe, pure, sortOn, ($), (&&&), (.), (<$>), (<&>), (<=), (>>=))
-import Yesod (ToContent (toContent), ToTypedContent (..), YesodPersist (runDB))
+import Yesod (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,22 +48,29 @@ instance ToTypedContent EosRes where
 
 getEosVersionR :: Handler (JSONResponse (Maybe EosRes))
 getEosVersionR = do
-    eosVersion <- queryParamAs "eos-version" parseVersion
+    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
-            orderBy [desc (vers ^. OsVersionCreatedAt)]
+                            where_ (vers ^. OsVersionArch ==. val (Just arch))
+                            orderBy [desc (vers ^. OsVersionNumber)]
                             pure vers
-    let osV = entityVal <$> allEosVersions
+                    let osV = determineMaxEosVersionAvailable maxVersion currentEosVersion' $ entityVal <$> allEosVersions
                     let mLatest = head osV
                     let mappedVersions =
                             ReleaseNotes $
                                 HM.fromList $
                                     sortOn (Down . fst) $
-                        filter (maybe (const True) (<) eosVersion . fst) $
+                                        filter (maybe (const True) (<) currentEosVersion . fst) $
                                             ((osVersionNumber &&& osVersionReleaseNotes))
                                                 <$> osV
-    tickleMAU
                     pure . JSONResponse $
                         mLatest <&> \latest ->
                             EosRes
@@ -64,3 +78,9 @@ getEosVersionR = do
                                 , 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

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)

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,13 +37,15 @@ getVersionLatestR = do
         getOsVersionQuery <&> \case
             Nothing -> const True
             Just v -> flip satisfies v
+    osArch <- getArchQuery
+    do
         case lookup "ids" getParameters of
             Nothing -> sendResponseStatus status400 (InvalidParamsE "get:ids" "<MISSING>")
             Just packages -> case eitherDecode $ LBS.fromStrict $ encodeUtf8 packages of
                 Left _ -> sendResponseStatus status400 (InvalidParamsE "get:ids" packages)
                 Right p -> do
                     let packageList = (,Nothing) <$> p
-                let source = getPkgDataSource p
+                    let source = getPkgDataSource p osArch
                     filteredPackages <-
                         runDB $
                             runConduit $

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 Handler.Util (basicRender, parseQueryParam, getArchQuery)
-import Lib.Error (S9Error (..))
 import Lib.PkgRepository (PkgRepo, getIcon, getManifest)
 import Lib.Types.Core (PkgId)
 import Lib.Types.Emver (Version, VersionRange (..), parseRange, satisfies, (<||))
 import Model (Category (..), Key (..), PkgDependency (..), VersionRecord (..))
-import Network.HTTP.Types (status400)
 import Protolude.Unsafe (unsafeFromJust)
 import Settings (AppSettings)
 import Startlude (
@@ -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,15 +115,17 @@ getPackageIndexR = do
         getOsVersionQuery <&> \case
             Nothing -> const True
             Just v -> flip satisfies v
+    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, const Any)
+                Nothing -> (serviceQuerySource category query osArch, const Any)
                 Just packages ->
-                let s = getPkgDataSource (packageReqId <$> packages)
+                    let s = getPkgDataSource (packageReqId <$> packages) osArch
                         r = fromMaybe None . (flip lookup $ (packageReqId &&& packageReqVersion) <$> packages)
                     in (s, r)
         filteredPackages <-
@@ -155,19 +150,6 @@ getPackageIndexR = do
         pkgsWithDependencies <- runDB $ mapConcurrently (getPackageDependencies osPredicate) filteredPackages
         PackageListRes <$> runConcurrently (zipWithM (Concurrently .* constructPackageListApiRes) filteredPackages pkgsWithDependencies)
 
-
-parseQueryParam :: Text -> (Text -> Either Text a) -> Handler (Maybe a)
-parseQueryParam param parser = do
-    lookupGetParam param >>= \case
-        Nothing -> pure Nothing
-        Just x -> case parser x of
-            Left e -> do
-                let err = InvalidParamsE ("get:" <> param) x
-                $logWarn e
-                sendResponseStatus status400 err
-            Right a -> pure (Just a)
-
-
 getPkgIdsQuery :: Handler (Maybe [PackageReq])
 getPkgIdsQuery = parseQueryParam "ids" (first toS . eitherDecodeStrict . encodeUtf8)
 

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)

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"

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")]

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

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@