mirror of
https://github.com/Start9Labs/registry.git
synced 2026-03-26 10:21:51 +00:00
refactor registry to include OS version filtering on the package index (#64)
* refactor registry to include OS version filtering on the package index * remove commented code, clean up tests * removed unused types * remove disabled test * remove unused type * fix query parsing * remove unused code * more purging * MOAR PURGING * normalize data model, fix all type errors * rename get parameter
This commit is contained in:
Keagan McClelland
@@ -4,61 +4,109 @@
|
||||
|
||||
module Database.Marketplace where
|
||||
|
||||
import Conduit ( ConduitT
|
||||
, MonadResource
|
||||
, MonadUnliftIO
|
||||
, awaitForever
|
||||
, yield
|
||||
)
|
||||
import Database.Esqueleto.Experimental
|
||||
( (%)
|
||||
, (&&.)
|
||||
, (++.)
|
||||
, (==.)
|
||||
, Entity(entityKey, entityVal)
|
||||
, SqlBackend
|
||||
, (^.)
|
||||
, desc
|
||||
, from
|
||||
, ilike
|
||||
, in_
|
||||
, innerJoin
|
||||
, on
|
||||
, orderBy
|
||||
, select
|
||||
, selectSource
|
||||
, val
|
||||
, valList
|
||||
, where_
|
||||
, (||.)
|
||||
)
|
||||
import Database.Esqueleto.Experimental
|
||||
( (:&)(..)
|
||||
, table
|
||||
)
|
||||
import Lib.Types.AppIndex ( PkgId )
|
||||
import Lib.Types.Category
|
||||
import Lib.Types.Emver ( Version )
|
||||
import Model
|
||||
import Startlude hiding ( (%)
|
||||
, from
|
||||
, on
|
||||
, yield
|
||||
)
|
||||
import Database.Esqueleto.Experimental
|
||||
import Lib.Types.Category
|
||||
import Model
|
||||
import qualified Database.Persist as P
|
||||
import Data.HashMap.Strict
|
||||
import Data.Version
|
||||
import Data.Aeson
|
||||
|
||||
searchServices :: MonadIO m => Maybe CategoryTitle -> Int64 -> Int64 -> Text -> ReaderT SqlBackend m [P.Entity SApp]
|
||||
searchServices Nothing pageItems offset' query = select $ do
|
||||
service <- from $ table @SApp
|
||||
searchServices :: (MonadResource m, MonadIO m)
|
||||
=> Maybe CategoryTitle
|
||||
-> Text
|
||||
-> ConduitT () (Entity PkgRecord) (ReaderT SqlBackend m) ()
|
||||
searchServices Nothing query = selectSource $ do
|
||||
service <- from $ table @PkgRecord
|
||||
where_
|
||||
( (service ^. SAppDescShort `ilike` (%) ++. val query ++. (%))
|
||||
||. (service ^. SAppDescLong `ilike` (%) ++. val query ++. (%))
|
||||
||. (service ^. SAppTitle `ilike` (%) ++. val query ++. (%))
|
||||
( (service ^. PkgRecordDescShort `ilike` (%) ++. val query ++. (%))
|
||||
||. (service ^. PkgRecordDescLong `ilike` (%) ++. val query ++. (%))
|
||||
||. (service ^. PkgRecordTitle `ilike` (%) ++. val query ++. (%))
|
||||
)
|
||||
orderBy [desc (service ^. SAppUpdatedAt)]
|
||||
limit pageItems
|
||||
offset offset'
|
||||
orderBy [desc (service ^. PkgRecordUpdatedAt)]
|
||||
pure service
|
||||
searchServices (Just category) pageItems offset' query = select $ do
|
||||
searchServices (Just category) query = selectSource $ do
|
||||
services <- from
|
||||
(do
|
||||
(service :& sc) <-
|
||||
(service :& _ :& cat) <-
|
||||
from
|
||||
$ table @SApp
|
||||
`innerJoin` table @ServiceCategory
|
||||
`on` (\(s :& sc) -> sc ^. ServiceCategoryServiceId ==. s ^. SAppId)
|
||||
-- if there is a cateogry, only search in category
|
||||
-- weight title, short, long (bitcoin should equal Bitcoin Core)
|
||||
$ table @PkgRecord
|
||||
`innerJoin` table @PkgCategory
|
||||
`on` (\(s :& sc) -> sc ^. PkgCategoryPkgId ==. s ^. PkgRecordId)
|
||||
`innerJoin` table @Category
|
||||
`on` (\(_ :& sc :& cat) -> sc ^. PkgCategoryCategoryId ==. cat ^. CategoryId)
|
||||
-- if there is a cateogry, only search in category
|
||||
-- weight title, short, long (bitcoin should equal Bitcoin Core)
|
||||
where_
|
||||
$ sc
|
||||
^. ServiceCategoryCategoryName
|
||||
$ cat
|
||||
^. CategoryName
|
||||
==. val category
|
||||
&&. ( (service ^. SAppDescShort `ilike` (%) ++. val query ++. (%))
|
||||
||. (service ^. SAppDescLong `ilike` (%) ++. val query ++. (%))
|
||||
||. (service ^. SAppTitle `ilike` (%) ++. val query ++. (%))
|
||||
&&. ( (service ^. PkgRecordDescShort `ilike` (%) ++. val query ++. (%))
|
||||
||. (service ^. PkgRecordDescLong `ilike` (%) ++. val query ++. (%))
|
||||
||. (service ^. PkgRecordTitle `ilike` (%) ++. val query ++. (%))
|
||||
)
|
||||
pure service
|
||||
)
|
||||
orderBy [desc (services ^. SAppUpdatedAt)]
|
||||
limit pageItems
|
||||
offset offset'
|
||||
orderBy [desc (services ^. PkgRecordUpdatedAt)]
|
||||
pure services
|
||||
|
||||
newtype VersionsWithReleaseNotes = VersionsWithReleaseNotes (HashMap Version Text) deriving (Eq, Show, Generic)
|
||||
instance FromJSON VersionsWithReleaseNotes
|
||||
instance PersistField VersionsWithReleaseNotes where
|
||||
fromPersistValue = fromPersistValueJSON
|
||||
toPersistValue = PersistText . show
|
||||
getPkgData :: (MonadResource m, MonadIO m) => [PkgId] -> ConduitT () (Entity PkgRecord) (ReaderT SqlBackend m) ()
|
||||
getPkgData pkgs = selectSource $ do
|
||||
pkgData <- from $ table @PkgRecord
|
||||
where_ (pkgData ^. PkgRecordId `in_` valList (PkgRecordKey <$> pkgs))
|
||||
pure pkgData
|
||||
|
||||
-- in progress attempt to do postgres aggregation with raw sql in esqueleto
|
||||
-- getServiceVersionsWithReleaseNotes :: MonadIO m => Text -> ReaderT SqlBackend m (Entity SApp)
|
||||
-- getServiceVersionsWithReleaseNotes appId = rawSql "SELECT ??, json_agg(json_build_object(v.number, v.release_notes)) as versions FROM s_app s LEFT JOIN version v ON v.app_id = s.id WHERE s.app_id = ? GROUP BY s.id;" [PersistText appId]
|
||||
zipVersions :: MonadUnliftIO m
|
||||
=> ConduitT (Entity PkgRecord) (Entity PkgRecord, [Entity VersionRecord]) (ReaderT SqlBackend m) ()
|
||||
zipVersions = awaitForever $ \i -> do
|
||||
let appDbId = entityKey i
|
||||
res <- lift $ select $ do
|
||||
v <- from $ table @VersionRecord
|
||||
where_ $ v ^. VersionRecordPkgId ==. val appDbId
|
||||
pure v
|
||||
yield (i, res)
|
||||
|
||||
filterOsCompatible :: Monad m
|
||||
=> (Version -> Bool)
|
||||
-> ConduitT
|
||||
(Entity PkgRecord, [Entity VersionRecord])
|
||||
(Entity PkgRecord, [Entity VersionRecord])
|
||||
m
|
||||
()
|
||||
filterOsCompatible p = awaitForever $ \(app, versions) -> do
|
||||
let compatible = filter (p . versionRecordOsVersion . entityVal) versions
|
||||
when (not $ null compatible) $ yield (app, compatible)
|
||||
|
||||
@@ -9,32 +9,15 @@ import Lib.Types.AppIndex
|
||||
import Lib.Types.Emver
|
||||
import Model
|
||||
import Orphans.Emver ( )
|
||||
import Startlude
|
||||
import Startlude hiding ( get )
|
||||
|
||||
fetchApp :: MonadIO m => PkgId -> ReaderT SqlBackend m (Maybe (Entity SApp))
|
||||
fetchApp appId = selectFirst [SAppAppId ==. appId] []
|
||||
fetchApp :: MonadIO m => PkgId -> ReaderT SqlBackend m (Maybe PkgRecord)
|
||||
fetchApp = get . PkgRecordKey
|
||||
|
||||
fetchAppVersion :: MonadIO m => Version -> Key SApp -> ReaderT SqlBackend m (Maybe (Entity SVersion))
|
||||
fetchAppVersion appVersion appId = selectFirst [SVersionNumber ==. appVersion, SVersionAppId ==. appId] []
|
||||
fetchAppVersion :: MonadIO m => PkgId -> Version -> ReaderT SqlBackend m (Maybe VersionRecord)
|
||||
fetchAppVersion pkgId version = get (VersionRecordKey (PkgRecordKey pkgId) version)
|
||||
|
||||
createApp :: MonadIO m => PkgId -> StoreApp -> ReaderT SqlBackend m (Maybe (Key SApp))
|
||||
createApp appId StoreApp {..} = do
|
||||
createMetric :: MonadIO m => PkgId -> Version -> ReaderT SqlBackend m ()
|
||||
createMetric appId version = do
|
||||
time <- liftIO getCurrentTime
|
||||
insertUnique $ SApp time Nothing storeAppTitle appId storeAppDescShort storeAppDescLong storeAppIconType
|
||||
|
||||
createAppVersion :: MonadIO m => Key SApp -> VersionInfo -> Text -> ReaderT SqlBackend m (Maybe (Key SVersion))
|
||||
createAppVersion sId VersionInfo {..} arch = do
|
||||
time <- liftIO getCurrentTime
|
||||
insertUnique $ SVersion time
|
||||
Nothing
|
||||
sId
|
||||
versionInfoVersion
|
||||
versionInfoReleaseNotes
|
||||
versionInfoOsRequired
|
||||
versionInfoOsRecommended
|
||||
(Just arch)
|
||||
|
||||
createMetric :: MonadIO m => Key SApp -> Key SVersion -> ReaderT SqlBackend m ()
|
||||
createMetric appId versionId = do
|
||||
time <- liftIO getCurrentTime
|
||||
insert_ $ Metric time appId versionId
|
||||
insert_ $ Metric time (PkgRecordKey appId) (VersionRecordKey (PkgRecordKey appId) version)
|
||||
|
||||
@@ -6,6 +6,7 @@
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
module Foundation where
|
||||
|
||||
import Startlude hiding ( Handler )
|
||||
@@ -64,12 +65,15 @@ instance Has PkgRepo RegistryCtx where
|
||||
let repo = f $ extract ctx
|
||||
settings = (appSettings ctx) { resourcesDir = pkgRepoFileRoot repo, staticBinDir = pkgRepoAppMgrBin repo }
|
||||
in ctx { appSettings = settings }
|
||||
instance Has PkgRepo (HandlerData RegistryCtx RegistryCtx) where
|
||||
instance Has a r => Has a (HandlerData r r) where
|
||||
extract = extract . rheSite . handlerEnv
|
||||
update f r =
|
||||
let ctx = update f (rheSite $ handlerEnv r)
|
||||
rhe = (handlerEnv r) { rheSite = ctx, rheChild = ctx }
|
||||
in r { handlerEnv = rhe }
|
||||
instance Has AppSettings RegistryCtx where
|
||||
extract = appSettings
|
||||
update f ctx = ctx { appSettings = f (appSettings ctx) }
|
||||
|
||||
|
||||
|
||||
|
||||
@@ -11,16 +11,8 @@ module Handler.Apps where
|
||||
|
||||
import Startlude hiding ( Handler )
|
||||
|
||||
import Control.Monad.Logger ( logError
|
||||
, logInfo
|
||||
)
|
||||
import Data.Aeson ( ToJSON
|
||||
, encode
|
||||
)
|
||||
import qualified Data.Attoparsec.Text as Atto
|
||||
import qualified Data.ByteString.Lazy as BS
|
||||
import Control.Monad.Logger ( logError )
|
||||
import qualified Data.Text as T
|
||||
import Database.Persist ( Entity(entityKey) )
|
||||
import qualified GHC.Show ( Show(..) )
|
||||
import Network.HTTP.Types ( status404 )
|
||||
import System.FilePath ( (<.>)
|
||||
@@ -34,7 +26,6 @@ import Yesod.Core ( TypedContent
|
||||
, sendResponseStatus
|
||||
, typeJson
|
||||
, typeOctet
|
||||
, waiRequest
|
||||
)
|
||||
import Yesod.Persist.Core ( YesodPersist(runDB) )
|
||||
|
||||
@@ -55,37 +46,17 @@ import Lib.PkgRepository ( getBestVersion
|
||||
)
|
||||
import Lib.Registry ( S9PK )
|
||||
import Lib.Types.AppIndex ( PkgId(PkgId) )
|
||||
import Lib.Types.Emver ( Version
|
||||
, parseVersion
|
||||
)
|
||||
import Network.Wai ( Request(requestHeaderUserAgent) )
|
||||
import Lib.Types.Emver ( Version )
|
||||
import Util.Shared ( addPackageHeader
|
||||
, getVersionSpecFromQuery
|
||||
, orThrow
|
||||
)
|
||||
|
||||
pureLog :: Show a => a -> Handler a
|
||||
pureLog = liftA2 (*>) ($logInfo . show) pure
|
||||
|
||||
logRet :: ToJSON a => Handler a -> Handler a
|
||||
logRet = (>>= liftA2 (*>) ($logInfo . decodeUtf8 . BS.toStrict . encode) pure)
|
||||
|
||||
data FileExtension = FileExtension FilePath (Maybe String)
|
||||
instance Show FileExtension where
|
||||
show (FileExtension f Nothing ) = f
|
||||
show (FileExtension f (Just e)) = f <.> e
|
||||
|
||||
userAgentOsVersionParser :: Atto.Parser Version
|
||||
userAgentOsVersionParser = do
|
||||
void $ (Atto.string "EmbassyOS" <|> Atto.string "AmbassadorOS" <|> Atto.string "MeshOS") *> Atto.char '/'
|
||||
parseVersion
|
||||
|
||||
getEmbassyOsVersion :: Handler (Maybe Version)
|
||||
getEmbassyOsVersion = userAgentOsVersion
|
||||
where
|
||||
userAgentOsVersion =
|
||||
(hush . Atto.parseOnly userAgentOsVersionParser . decodeUtf8 <=< requestHeaderUserAgent) <$> waiRequest
|
||||
|
||||
getAppManifestR :: PkgId -> Handler TypedContent
|
||||
getAppManifestR pkg = do
|
||||
versionSpec <- getVersionSpecFromQuery
|
||||
@@ -116,12 +87,11 @@ recordMetrics pkg appVersion = do
|
||||
Nothing -> do
|
||||
$logError $ [i|#{pkg} not found in database|]
|
||||
notFound
|
||||
Just a -> do
|
||||
let appKey' = entityKey a
|
||||
existingVersion <- runDB $ fetchAppVersion appVersion appKey'
|
||||
Just _ -> do
|
||||
existingVersion <- runDB $ fetchAppVersion pkg appVersion
|
||||
case existingVersion of
|
||||
Nothing -> do
|
||||
$logError $ [i|#{pkg}@#{appVersion} not found in database|]
|
||||
notFound
|
||||
Just v -> runDB $ createMetric (entityKey a) (entityKey v)
|
||||
Just _ -> runDB $ createMetric pkg appVersion
|
||||
|
||||
|
||||
@@ -32,11 +32,6 @@ data IconType = PNG | JPG | JPEG | SVG
|
||||
instance ToJSON IconType
|
||||
instance FromJSON IconType
|
||||
|
||||
-- >>> readMaybe $ ixt :: Maybe IconType
|
||||
-- Just PNG
|
||||
ixt :: Text
|
||||
ixt = toS $ toUpper <$> drop 1 ".png"
|
||||
|
||||
getIconsR :: PkgId -> Handler TypedContent
|
||||
getIconsR pkg = do
|
||||
spec <- getVersionSpecFromQuery
|
||||
|
||||
@@ -1,18 +1,16 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
|
||||
module Handler.Marketplace where
|
||||
|
||||
import Startlude hiding ( Handler
|
||||
import Startlude hiding ( Any
|
||||
, Handler
|
||||
, ask
|
||||
, from
|
||||
, on
|
||||
, sortOn
|
||||
@@ -20,10 +18,17 @@ import Startlude hiding ( Handler
|
||||
|
||||
import Conduit ( (.|)
|
||||
, awaitForever
|
||||
, dropC
|
||||
, mapC
|
||||
, runConduit
|
||||
, sinkList
|
||||
, sourceFile
|
||||
, takeC
|
||||
)
|
||||
import Control.Monad.Except.CoHas ( liftEither )
|
||||
import Control.Monad.Reader.Has ( Has
|
||||
, ask
|
||||
)
|
||||
import Control.Parallel.Strategies ( parMap
|
||||
, rpar
|
||||
)
|
||||
@@ -51,32 +56,29 @@ import Data.String.Interpolate.IsString
|
||||
( i )
|
||||
import qualified Data.Text as T
|
||||
import Database.Esqueleto.Experimental
|
||||
( (&&.)
|
||||
, (:&)((:&))
|
||||
( (:&)((:&))
|
||||
, (==.)
|
||||
, (?.)
|
||||
, Entity(entityKey, entityVal)
|
||||
, PersistEntity(Key)
|
||||
, SqlBackend
|
||||
, Value(unValue)
|
||||
, (^.)
|
||||
, desc
|
||||
, from
|
||||
, groupBy
|
||||
, in_
|
||||
, innerJoin
|
||||
, just
|
||||
, leftJoin
|
||||
, limit
|
||||
, on
|
||||
, orderBy
|
||||
, select
|
||||
, selectOne
|
||||
, table
|
||||
, val
|
||||
, valList
|
||||
, where_
|
||||
)
|
||||
import Database.Esqueleto.PostgreSQL ( arrayAggDistinct )
|
||||
import Database.Marketplace ( searchServices )
|
||||
import Database.Marketplace ( filterOsCompatible
|
||||
, getPkgData
|
||||
, searchServices
|
||||
, zipVersions
|
||||
)
|
||||
import qualified Database.Persist as P
|
||||
import Foundation ( Handler
|
||||
, RegistryCtx(appSettings)
|
||||
@@ -89,19 +91,21 @@ import Lib.Types.AppIndex ( PkgId(PkgId)
|
||||
, VersionInfo(..)
|
||||
)
|
||||
import Lib.Types.AppIndex ( )
|
||||
import Lib.Types.Category ( CategoryTitle(FEATURED) )
|
||||
import Lib.Types.Category ( CategoryTitle(..) )
|
||||
import Lib.Types.Emver ( (<||)
|
||||
, Version
|
||||
, VersionRange
|
||||
, VersionRange(Any)
|
||||
, parseRange
|
||||
, parseVersion
|
||||
, satisfies
|
||||
)
|
||||
import Model ( Category(..)
|
||||
, EntityField(..)
|
||||
, Key(PkgRecordKey, unPkgRecordKey)
|
||||
, OsVersion(..)
|
||||
, SApp(..)
|
||||
, SVersion(..)
|
||||
, ServiceCategory
|
||||
, PkgCategory
|
||||
, PkgRecord(..)
|
||||
, VersionRecord(..)
|
||||
)
|
||||
import Network.HTTP.Types ( status400
|
||||
, status404
|
||||
@@ -110,17 +114,10 @@ import Protolude.Unsafe ( unsafeFromJust )
|
||||
import Settings ( AppSettings(registryHostname, resourcesDir) )
|
||||
import System.Directory ( getFileSize )
|
||||
import System.FilePath ( (</>) )
|
||||
import UnliftIO.Async ( concurrently
|
||||
, mapConcurrently
|
||||
)
|
||||
import UnliftIO.Async ( mapConcurrently )
|
||||
import UnliftIO.Directory ( listDirectory )
|
||||
import Util.Shared ( getVersionSpecFromQuery
|
||||
, orThrow
|
||||
)
|
||||
import Yesod.Core ( HandlerFor
|
||||
, MonadLogger
|
||||
, MonadResource
|
||||
, MonadUnliftIO
|
||||
import Util.Shared ( getVersionSpecFromQuery )
|
||||
import Yesod.Core ( MonadResource
|
||||
, ToContent(..)
|
||||
, ToTypedContent(..)
|
||||
, TypedContent
|
||||
@@ -142,7 +139,6 @@ newtype CategoryRes = CategoryRes {
|
||||
categories :: [CategoryTitle]
|
||||
} deriving (Show, Generic)
|
||||
instance ToJSON CategoryRes
|
||||
instance FromJSON CategoryRes
|
||||
instance ToContent CategoryRes where
|
||||
toContent = toContent . toJSON
|
||||
instance ToTypedContent CategoryRes where
|
||||
@@ -176,10 +172,6 @@ instance ToJSON ServiceRes where
|
||||
, "versions" .= serviceResVersions
|
||||
, "dependency-metadata" .= serviceResDependencyInfo
|
||||
]
|
||||
instance ToContent ServiceRes where
|
||||
toContent = toContent . toJSON
|
||||
instance ToTypedContent ServiceRes where
|
||||
toTypedContent = toTypedContent . toJSON
|
||||
data DependencyInfo = DependencyInfo
|
||||
{ dependencyInfoTitle :: PkgId
|
||||
, dependencyInfoIcon :: URL
|
||||
@@ -188,40 +180,6 @@ data DependencyInfo = DependencyInfo
|
||||
instance ToJSON DependencyInfo where
|
||||
toJSON DependencyInfo {..} = object ["icon" .= dependencyInfoIcon, "title" .= dependencyInfoTitle]
|
||||
|
||||
data ServiceListRes = ServiceListRes
|
||||
{ serviceListResCategories :: [CategoryTitle]
|
||||
, serviceListResServices :: [ServiceAvailable]
|
||||
}
|
||||
deriving Show
|
||||
instance ToJSON ServiceListRes where
|
||||
toJSON ServiceListRes {..} =
|
||||
object ["categories" .= serviceListResCategories, "services" .= serviceListResServices]
|
||||
instance ToContent ServiceListRes where
|
||||
toContent = toContent . toJSON
|
||||
instance ToTypedContent ServiceListRes where
|
||||
toTypedContent = toTypedContent . toJSON
|
||||
|
||||
data ServiceAvailable = ServiceAvailable
|
||||
{ serviceAvailableId :: PkgId
|
||||
, serviceAvailableTitle :: Text
|
||||
, serviceAvailableVersion :: Version
|
||||
, serviceAvailableIcon :: URL
|
||||
, serviceAvailableDescShort :: Text
|
||||
}
|
||||
deriving Show
|
||||
instance ToJSON ServiceAvailable where
|
||||
toJSON ServiceAvailable {..} = object
|
||||
[ "id" .= serviceAvailableId
|
||||
, "title" .= serviceAvailableTitle
|
||||
, "version" .= serviceAvailableVersion
|
||||
, "icon" .= serviceAvailableIcon
|
||||
, "descriptionShort" .= serviceAvailableDescShort
|
||||
]
|
||||
instance ToContent ServiceAvailable where
|
||||
toContent = toContent . toJSON
|
||||
instance ToTypedContent ServiceAvailable where
|
||||
toTypedContent = toTypedContent . toJSON
|
||||
|
||||
newtype ServiceAvailableRes = ServiceAvailableRes [ServiceRes]
|
||||
deriving (Generic)
|
||||
instance ToJSON ServiceAvailableRes
|
||||
@@ -241,8 +199,8 @@ data OrderArrangement = ASC | DESC
|
||||
deriving (Eq, Show, Read)
|
||||
data ServiceListDefaults = ServiceListDefaults
|
||||
{ serviceListOrder :: OrderArrangement
|
||||
, serviceListPageLimit :: Int64 -- the number of items per page
|
||||
, serviceListPageNumber :: Int64 -- the page you are on
|
||||
, serviceListPageLimit :: Int -- the number of items per page
|
||||
, serviceListPageNumber :: Int -- the page you are on
|
||||
, serviceListCategory :: Maybe CategoryTitle
|
||||
, serviceListQuery :: Text
|
||||
}
|
||||
@@ -305,11 +263,8 @@ getReleaseNotesR = do
|
||||
case lookup "id" getParameters of
|
||||
Nothing -> sendResponseStatus status400 (InvalidParamsE "get:id" "<MISSING>")
|
||||
Just package -> do
|
||||
(service, _) <- runDB $ fetchLatestApp (PkgId package) `orThrow` sendResponseStatus
|
||||
status404
|
||||
(NotFoundE $ show package)
|
||||
(_, mappedVersions) <- fetchAllAppVersions (entityKey service)
|
||||
pure mappedVersions
|
||||
(_, notes) <- fetchAllAppVersions (PkgId package)
|
||||
pure notes
|
||||
|
||||
getEosR :: Handler TypedContent
|
||||
getEosR = do
|
||||
@@ -332,50 +287,70 @@ getVersionLatestR = do
|
||||
case lookup "ids" getParameters of
|
||||
Nothing -> sendResponseStatus status400 (InvalidParamsE "get:ids" "<MISSING>")
|
||||
Just packages -> case eitherDecode $ BS.fromStrict $ encodeUtf8 packages of
|
||||
Left _ -> sendResponseStatus status400 (InvalidParamsE "get:ids" packages)
|
||||
Right (p :: [PkgId]) -> do
|
||||
let packageList :: [(PkgId, Maybe Version)] = (, Nothing) <$> p
|
||||
Left _ -> sendResponseStatus status400 (InvalidParamsE "get:ids" packages)
|
||||
Right p -> do
|
||||
let packageList = (, Nothing) <$> p
|
||||
found <- runDB $ traverse fetchLatestApp $ fst <$> packageList
|
||||
pure
|
||||
$ VersionLatestRes
|
||||
$ HM.union
|
||||
( HM.fromList
|
||||
$ (\v -> (sAppAppId $ entityVal $ fst v, Just $ sVersionNumber $ entityVal $ snd v))
|
||||
$ (\v ->
|
||||
(unPkgRecordKey . entityKey $ fst v, Just $ versionRecordNumber $ entityVal $ snd v)
|
||||
)
|
||||
<$> catMaybes found
|
||||
)
|
||||
$ HM.fromList packageList
|
||||
|
||||
getPackageListR :: Handler ServiceAvailableRes
|
||||
getPackageListR = do
|
||||
pkgIds <- getPkgIdsQuery
|
||||
case pkgIds of
|
||||
osPredicate <- getOsVersionQuery <&> \case
|
||||
Nothing -> const True
|
||||
Just v -> flip satisfies v
|
||||
pkgIds <- getPkgIdsQuery
|
||||
filteredServices <- case pkgIds of
|
||||
Nothing -> do
|
||||
-- query for all
|
||||
category <- getCategoryQuery
|
||||
page <- getPageQuery
|
||||
limit' <- getLimitQuery
|
||||
query <- T.strip . fromMaybe (serviceListQuery defaults) <$> lookupGetParam "query"
|
||||
filteredServices <- runDB $ searchServices category limit' ((page - 1) * limit') query
|
||||
let filteredServices' = sAppAppId . entityVal <$> filteredServices
|
||||
settings <- getsYesod appSettings
|
||||
packageMetadata <- runDB $ fetchPackageMetadata
|
||||
serviceDetailResult <- mapConcurrently (getServiceDetails settings packageMetadata Nothing)
|
||||
filteredServices'
|
||||
let (_, services) = partitionEithers serviceDetailResult
|
||||
pure $ ServiceAvailableRes services
|
||||
|
||||
category <- getCategoryQuery
|
||||
page <- getPageQuery
|
||||
limit' <- getLimitQuery
|
||||
query <- T.strip . fromMaybe (serviceListQuery defaults) <$> lookupGetParam "query"
|
||||
runDB
|
||||
$ runConduit
|
||||
$ searchServices category query
|
||||
.| zipVersions
|
||||
.| filterOsCompatible osPredicate
|
||||
-- pages start at 1 for some reason. TODO: make pages start at 0
|
||||
.| (dropC (limit' * (page - 1)) *> takeC limit')
|
||||
.| sinkList
|
||||
Just packages -> do
|
||||
-- for each item in list get best available from version range
|
||||
settings <- getsYesod appSettings
|
||||
-- @TODO fix _ error
|
||||
packageMetadata <- runDB $ fetchPackageMetadata
|
||||
availableServicesResult <- traverse (getPackageDetails packageMetadata) packages
|
||||
let (_, availableServices) = partitionEithers availableServicesResult
|
||||
serviceDetailResult <- mapConcurrently (uncurry $ getServiceDetails settings packageMetadata)
|
||||
availableServices
|
||||
-- @TODO fix _ error
|
||||
let (_, services) = partitionEithers serviceDetailResult
|
||||
pure $ ServiceAvailableRes services
|
||||
-- for each item in list get best available from version range
|
||||
let vMap = (packageVersionId &&& packageVersionVersion) <$> packages
|
||||
runDB
|
||||
. runConduit
|
||||
$ getPkgData (packageVersionId <$> packages)
|
||||
.| zipVersions
|
||||
.| mapC
|
||||
(\(a, vs) ->
|
||||
let spec = fromMaybe Any $ lookup (unPkgRecordKey $ entityKey a) vMap
|
||||
in (a, filter ((<|| spec) . versionRecordNumber . entityVal) vs)
|
||||
)
|
||||
.| filterOsCompatible osPredicate
|
||||
.| sinkList
|
||||
let keys = unPkgRecordKey . entityKey . fst <$> filteredServices
|
||||
cats <- runDB $ fetchAppCategories keys
|
||||
let vers =
|
||||
filteredServices
|
||||
<&> first (unPkgRecordKey . entityKey)
|
||||
<&> second (sortOn Down . fmap (versionRecordNumber . entityVal))
|
||||
& HM.fromListWith (++)
|
||||
let packageMetadata = HM.intersectionWith (,) vers (categoryName <<$>> cats)
|
||||
serviceDetailResult <- mapConcurrently (flip (getServiceDetails packageMetadata) Nothing)
|
||||
(unPkgRecordKey . entityKey . fst <$> filteredServices)
|
||||
let services = snd $ partitionEithers serviceDetailResult
|
||||
pure $ ServiceAvailableRes services
|
||||
|
||||
|
||||
where
|
||||
defaults = ServiceListDefaults { serviceListOrder = DESC
|
||||
, serviceListPageLimit = 20
|
||||
@@ -401,7 +376,7 @@ getPackageListR = do
|
||||
$logWarn (show e)
|
||||
sendResponseStatus status400 e
|
||||
Just t -> pure $ Just t
|
||||
getPageQuery :: Handler Int64
|
||||
getPageQuery :: Handler Int
|
||||
getPageQuery = lookupGetParam "page" >>= \case
|
||||
Nothing -> pure $ serviceListPageNumber defaults
|
||||
Just p -> case readMaybe p of
|
||||
@@ -412,7 +387,7 @@ getPackageListR = do
|
||||
Just t -> pure $ case t of
|
||||
0 -> 1 -- disallow page 0 so offset is not negative
|
||||
_ -> t
|
||||
getLimitQuery :: Handler Int64
|
||||
getLimitQuery :: Handler Int
|
||||
getLimitQuery = lookupGetParam "per-page" >>= \case
|
||||
Nothing -> pure $ serviceListPageLimit defaults
|
||||
Just pp -> case readMaybe pp of
|
||||
@@ -421,31 +396,23 @@ getPackageListR = do
|
||||
$logWarn (show e)
|
||||
sendResponseStatus status400 e
|
||||
Just l -> pure l
|
||||
getPackageDetails :: MonadIO m
|
||||
=> (HM.HashMap PkgId ([Version], [CategoryTitle]))
|
||||
-> PackageVersion
|
||||
-> m (Either Text ((Maybe Version), PkgId))
|
||||
getPackageDetails metadata pv = do
|
||||
let appId = packageVersionId pv
|
||||
let spec = packageVersionVersion pv
|
||||
pacakgeMetadata <- case HM.lookup appId metadata of
|
||||
Nothing -> throwIO $ NotFoundE [i|dependency metadata for #{appId} not found.|]
|
||||
Just m -> pure m
|
||||
-- get best version from VersionRange of dependency
|
||||
let satisfactory = filter (<|| spec) (fst pacakgeMetadata)
|
||||
let best = getMax <$> foldMap (Just . Max) satisfactory
|
||||
case best of
|
||||
Nothing -> pure $ Left $ [i|Best version could not be found for #{appId} with spec #{spec}|]
|
||||
Just v -> do
|
||||
pure $ Right (Just v, appId)
|
||||
getOsVersionQuery :: Handler (Maybe VersionRange)
|
||||
getOsVersionQuery = lookupGetParam "eos-version-range" >>= \case
|
||||
Nothing -> pure Nothing
|
||||
Just osv -> case Atto.parseOnly parseRange osv of
|
||||
Left _ -> do
|
||||
let e = InvalidParamsE "get:eos-version-range" osv
|
||||
$logWarn (show e)
|
||||
sendResponseStatus status400 e
|
||||
Right v -> pure $ Just v
|
||||
|
||||
getServiceDetails :: (MonadIO m, MonadResource m)
|
||||
=> AppSettings
|
||||
-> (HM.HashMap PkgId ([Version], [CategoryTitle]))
|
||||
-> Maybe Version
|
||||
getServiceDetails :: (MonadIO m, MonadResource m, MonadReader r m, Has AppSettings r)
|
||||
=> (HM.HashMap PkgId ([Version], [CategoryTitle]))
|
||||
-> PkgId
|
||||
-> Maybe Version
|
||||
-> m (Either S9Error ServiceRes)
|
||||
getServiceDetails settings metadata maybeVersion pkg = runExceptT $ do
|
||||
getServiceDetails metadata pkg maybeVersion = runExceptT $ do
|
||||
settings <- ask
|
||||
packageMetadata <- case HM.lookup pkg metadata of
|
||||
Nothing -> liftEither . Left $ NotFoundE [i|#{pkg} not found.|]
|
||||
Just m -> pure m
|
||||
@@ -494,117 +461,49 @@ mapDependencyMetadata domain metadata (appId, depInfo) = do
|
||||
}
|
||||
)
|
||||
|
||||
fetchAllAppVersions :: Key SApp -> HandlerFor RegistryCtx ([VersionInfo], ReleaseNotes)
|
||||
fetchAllAppVersions :: PkgId -> Handler ([VersionInfo], ReleaseNotes)
|
||||
fetchAllAppVersions appId = do
|
||||
entityAppVersions <- runDB $ P.selectList [SVersionAppId P.==. appId] []
|
||||
entityAppVersions <- runDB $ P.selectList [VersionRecordPkgId P.==. PkgRecordKey appId] []
|
||||
let vers = entityVal <$> entityAppVersions
|
||||
let vv = mapSVersionToVersionInfo vers
|
||||
let mappedVersions = ReleaseNotes $ HM.fromList $ (\v -> (versionInfoVersion v, versionInfoReleaseNotes v)) <$> vv
|
||||
pure (sortOn (Down . versionInfoVersion) vv, mappedVersions)
|
||||
where
|
||||
mapSVersionToVersionInfo :: [SVersion] -> [VersionInfo]
|
||||
mapSVersionToVersionInfo :: [VersionRecord] -> [VersionInfo]
|
||||
mapSVersionToVersionInfo sv = do
|
||||
(\v -> VersionInfo { versionInfoVersion = sVersionNumber v
|
||||
, versionInfoReleaseNotes = sVersionReleaseNotes v
|
||||
, versionInfoDependencies = HM.empty
|
||||
, versionInfoOsRequired = sVersionOsVersionRequired v
|
||||
, versionInfoOsRecommended = sVersionOsVersionRecommended v
|
||||
, versionInfoInstallAlert = Nothing
|
||||
(\v -> VersionInfo { versionInfoVersion = versionRecordNumber v
|
||||
, versionInfoReleaseNotes = versionRecordReleaseNotes v
|
||||
, versionInfoDependencies = HM.empty
|
||||
, versionInfoOsVersion = versionRecordOsVersion v
|
||||
, versionInfoInstallAlert = Nothing
|
||||
}
|
||||
)
|
||||
<$> sv
|
||||
|
||||
fetchMostRecentAppVersions :: MonadIO m => Key SApp -> ReaderT SqlBackend m [Entity SVersion]
|
||||
fetchMostRecentAppVersions appId = sortResults $ select $ do
|
||||
version <- from $ table @SVersion
|
||||
where_ (version ^. SVersionAppId ==. val appId)
|
||||
limit 1
|
||||
pure version
|
||||
where sortResults = fmap $ sortOn (Down . sVersionNumber . entityVal)
|
||||
|
||||
fetchLatestApp :: MonadIO m => PkgId -> ReaderT SqlBackend m (Maybe (P.Entity SApp, P.Entity SVersion))
|
||||
fetchLatestApp :: MonadIO m => PkgId -> ReaderT SqlBackend m (Maybe (P.Entity PkgRecord, P.Entity VersionRecord))
|
||||
fetchLatestApp appId = fmap headMay . sortResults . select $ do
|
||||
(service :& version) <-
|
||||
from
|
||||
$ table @SApp
|
||||
`innerJoin` table @SVersion
|
||||
`on` (\(service :& version) -> service ^. SAppId ==. version ^. SVersionAppId)
|
||||
where_ (service ^. SAppAppId ==. val appId)
|
||||
$ table @PkgRecord
|
||||
`innerJoin` table @VersionRecord
|
||||
`on` (\(service :& version) -> service ^. PkgRecordId ==. version ^. VersionRecordPkgId)
|
||||
where_ (service ^. PkgRecordId ==. val (PkgRecordKey appId))
|
||||
pure (service, version)
|
||||
where sortResults = fmap $ sortOn (Down . sVersionNumber . entityVal . snd)
|
||||
where sortResults = fmap $ sortOn (Down . versionRecordNumber . entityVal . snd)
|
||||
|
||||
fetchLatestAppAtVersion :: MonadIO m
|
||||
=> PkgId
|
||||
-> Version
|
||||
-> ReaderT SqlBackend m (Maybe (P.Entity SApp, P.Entity SVersion))
|
||||
fetchLatestAppAtVersion appId version' = selectOne $ do
|
||||
(service :& version) <-
|
||||
from
|
||||
$ table @SApp
|
||||
`innerJoin` table @SVersion
|
||||
`on` (\(service :& version) -> service ^. SAppId ==. version ^. SVersionAppId)
|
||||
where_ $ (service ^. SAppAppId ==. val appId) &&. (version ^. SVersionNumber ==. val version')
|
||||
pure (service, version)
|
||||
|
||||
fetchPackageMetadata :: (MonadLogger m, MonadUnliftIO m)
|
||||
=> ReaderT SqlBackend m (HM.HashMap PkgId ([Version], [CategoryTitle]))
|
||||
fetchPackageMetadata = do
|
||||
let categoriesQuery = select $ do
|
||||
(service :& category) <-
|
||||
from
|
||||
$ table @SApp
|
||||
`leftJoin` table @ServiceCategory
|
||||
`on` (\(service :& category) ->
|
||||
Database.Esqueleto.Experimental.just (service ^. SAppId)
|
||||
==. category
|
||||
?. ServiceCategoryServiceId
|
||||
)
|
||||
Database.Esqueleto.Experimental.groupBy $ service ^. SAppAppId
|
||||
pure (service ^. SAppAppId, arrayAggDistinct (category ?. ServiceCategoryCategoryName))
|
||||
let versionsQuery = select $ do
|
||||
(service :& version) <-
|
||||
from
|
||||
$ table @SApp
|
||||
`innerJoin` table @SVersion
|
||||
`on` (\(service :& version) -> (service ^. SAppId) ==. version ^. SVersionAppId)
|
||||
Database.Esqueleto.Experimental.groupBy $ (service ^. SAppAppId, version ^. SVersionNumber)
|
||||
pure (service ^. SAppAppId, arrayAggDistinct (version ^. SVersionNumber))
|
||||
(categories, versions) <- UnliftIO.Async.concurrently categoriesQuery versionsQuery
|
||||
let
|
||||
c = foreach categories
|
||||
$ \(appId, categories') -> (unValue appId, catMaybes $ fromMaybe [] (unValue categories'))
|
||||
let v = foreach versions $ \(appId, versions') -> (unValue appId, fromMaybe [] (unValue versions'))
|
||||
let vv = HM.fromListWithKey (\_ vers vers' -> (++) vers vers') v
|
||||
pure $ HM.intersectionWith (\cts vers -> (vers, cts)) (HM.fromList c) (sortVersions vv)
|
||||
where sortVersions = fmap $ sortOn Down
|
||||
|
||||
fetchAppCategories :: MonadIO m => Key SApp -> ReaderT SqlBackend m [P.Entity ServiceCategory]
|
||||
fetchAppCategories appId = select $ do
|
||||
(categories :& service) <-
|
||||
from
|
||||
$ table @ServiceCategory
|
||||
`innerJoin` table @SApp
|
||||
`on` (\(sc :& s) -> sc ^. ServiceCategoryServiceId ==. s ^. SAppId)
|
||||
where_ (service ^. SAppId ==. val appId)
|
||||
pure categories
|
||||
|
||||
-- >>> encode hm
|
||||
-- "{\"0.2.0\":\"some notes\"}"
|
||||
hm :: Data.Aeson.Value
|
||||
hm = object [ t .= v | (k, v) <- [("0.2.0", "some notes") :: (Version, Text)], let (String t) = toJSON k ]
|
||||
|
||||
-- >>> encode rn
|
||||
-- "{\"0.2.0\":\"notes one\",\"0.3.0\":\"notes two\"}"
|
||||
rn :: ReleaseNotes
|
||||
rn = ReleaseNotes $ HM.fromList [("0.2.0", "notes one"), ("0.3.0", "notes two")]
|
||||
|
||||
-- >>> readMaybe $ cc :: Maybe CategoryTitle
|
||||
-- Just FEATURED
|
||||
cc :: Text
|
||||
cc = T.toUpper "featured"
|
||||
|
||||
-- >>> encode ccc
|
||||
-- "\"featured\""
|
||||
ccc :: CategoryTitle
|
||||
ccc = FEATURED
|
||||
|
||||
fetchAppCategories :: MonadIO m => [PkgId] -> ReaderT SqlBackend m (HM.HashMap PkgId [Category])
|
||||
fetchAppCategories appIds = do
|
||||
raw <- select $ do
|
||||
(sc :& app :& cat) <-
|
||||
from
|
||||
$ table @PkgCategory
|
||||
`innerJoin` table @PkgRecord
|
||||
`on` (\(sc :& app) -> sc ^. PkgCategoryPkgId ==. app ^. PkgRecordId)
|
||||
`innerJoin` table @Category
|
||||
`on` (\(sc :& _ :& cat) -> sc ^. PkgCategoryCategoryId ==. cat ^. CategoryId)
|
||||
where_ (sc ^. PkgCategoryPkgId `in_` valList (PkgRecordKey <$> appIds))
|
||||
pure (app ^. PkgRecordId, cat)
|
||||
let ls = fmap (first (unPkgRecordKey . unValue) . second (pure . entityVal)) raw
|
||||
pure $ HM.fromListWith (++) ls
|
||||
|
||||
@@ -8,7 +8,6 @@ import Startlude hiding ( toLower )
|
||||
import Data.Aeson
|
||||
import Yesod.Core.Content
|
||||
|
||||
import Data.Text
|
||||
import Lib.Types.Emver
|
||||
import Orphans.Emver ( )
|
||||
|
||||
@@ -26,23 +25,3 @@ instance ToContent (Maybe AppVersionRes) where
|
||||
toContent = toContent . toJSON
|
||||
instance ToTypedContent (Maybe AppVersionRes) where
|
||||
toTypedContent = toTypedContent . toJSON
|
||||
|
||||
-- status - nothing, available, instuctions
|
||||
-- version - semver string
|
||||
|
||||
data SystemStatus = NOTHING | AVAILABLE | INSTRUCTIONS
|
||||
deriving (Eq, Show)
|
||||
instance ToJSON SystemStatus where
|
||||
toJSON = String . toLower . show
|
||||
|
||||
data OSVersionRes = OSVersionRes
|
||||
{ osVersionStatus :: SystemStatus
|
||||
, osVersionVersion :: Version
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
instance ToJSON OSVersionRes where
|
||||
toJSON OSVersionRes {..} = object ["status" .= osVersionStatus, "version" .= osVersionVersion]
|
||||
instance ToContent OSVersionRes where
|
||||
toContent = toContent . toJSON
|
||||
instance ToTypedContent OSVersionRes where
|
||||
toTypedContent = toTypedContent . toJSON
|
||||
|
||||
@@ -19,14 +19,10 @@ import Lib.Error ( S9Error(NotFoundE) )
|
||||
import Lib.PkgRepository ( getBestVersion )
|
||||
import Lib.Types.AppIndex ( PkgId )
|
||||
import Network.HTTP.Types.Status ( status404 )
|
||||
import Settings
|
||||
import Util.Shared ( getVersionSpecFromQuery
|
||||
, orThrow
|
||||
)
|
||||
|
||||
getVersionR :: Handler AppVersionRes
|
||||
getVersionR = AppVersionRes . registryVersion . appSettings <$> getYesod
|
||||
|
||||
getPkgVersionR :: PkgId -> Handler AppVersionRes
|
||||
getPkgVersionR pkg = do
|
||||
spec <- getVersionSpecFromQuery
|
||||
|
||||
@@ -64,19 +64,3 @@ toStatus = \case
|
||||
NotFoundE _ -> status404
|
||||
InvalidParamsE _ _ -> status400
|
||||
AssetParseE _ _ -> status500
|
||||
|
||||
|
||||
handleS9ErrT :: MonadHandler m => S9ErrT m a -> m a
|
||||
handleS9ErrT action = runExceptT action >>= \case
|
||||
Left e -> toStatus >>= sendResponseStatus $ e
|
||||
Right a -> pure a
|
||||
|
||||
handleS9ErrNuclear :: MonadIO m => S9ErrT m a -> m a
|
||||
handleS9ErrNuclear action = runExceptT action >>= \case
|
||||
Left e -> throwIO e
|
||||
Right a -> pure a
|
||||
|
||||
errOnNothing :: MonadHandler m => Status -> Text -> Maybe a -> m a
|
||||
errOnNothing status res entity = case entity of
|
||||
Nothing -> sendResponseStatus status res
|
||||
Just a -> pure a
|
||||
|
||||
@@ -2,71 +2,18 @@
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module Lib.Registry where
|
||||
|
||||
import Startlude
|
||||
|
||||
import qualified Data.Attoparsec.Text as Atto
|
||||
import Data.HashMap.Lazy hiding ( mapMaybe )
|
||||
import qualified GHC.Read ( Read(..) )
|
||||
import qualified GHC.Show ( Show(..) )
|
||||
import System.Directory
|
||||
import System.FilePath
|
||||
import Yesod.Core
|
||||
|
||||
import Lib.Types.Emver
|
||||
|
||||
type Registry = HashMap String (HashMap Version FilePath)
|
||||
|
||||
newtype RegisteredAppVersion = RegisteredAppVersion { unRegisteredAppVersion :: (Version, FilePath) } deriving (Eq, Show)
|
||||
data MaxVersion a = MaxVersion
|
||||
{ getMaxVersion :: (a, a -> Version)
|
||||
}
|
||||
instance Semigroup (MaxVersion a) where
|
||||
(MaxVersion (a, f)) <> (MaxVersion (b, g)) = if f a > g b then MaxVersion (a, f) else MaxVersion (b, g)
|
||||
|
||||
-- retrieve all valid semver folder names with queried for file: rootDirectory/appId/[0.0.0 ...]/appId.extension
|
||||
-- @TODO move to db query after all appversions are seeded qith post 0.3.0 migration script
|
||||
getAvailableAppVersions :: KnownSymbol a => FilePath -> Extension a -> IO [RegisteredAppVersion]
|
||||
getAvailableAppVersions rootDirectory ext@(Extension appId) = do
|
||||
versions <- mapMaybe (hush . Atto.parseOnly parseVersion . toS) <$> getSubDirectories (rootDirectory </> appId)
|
||||
fmap catMaybes . for versions $ \v -> getVersionedFileFromDir rootDirectory ext v >>= \case
|
||||
Nothing -> pure Nothing
|
||||
Just appFile -> pure . Just $ RegisteredAppVersion (v, appFile)
|
||||
where
|
||||
getSubDirectories path = (fmap (fromRight []) . try @SomeException $ listDirectory path)
|
||||
>>= filterM (doesDirectoryExist . (path </>))
|
||||
|
||||
-- this works for both service versions and embassyOS versions
|
||||
getMostRecentAppVersion :: KnownSymbol a => FilePath -> Extension a -> IO (Maybe RegisteredAppVersion)
|
||||
getMostRecentAppVersion rootDirectory ext = do
|
||||
allVersions <- liftIO $ getAvailableAppVersions rootDirectory ext
|
||||
pure $ head $ sortOn (Down . fst . unRegisteredAppVersion) allVersions
|
||||
|
||||
-- /root/appId/version/appId.ext
|
||||
getVersionedFileFromDir :: KnownSymbol a => FilePath -> Extension a -> Version -> IO (Maybe FilePath)
|
||||
getVersionedFileFromDir rootDirectory ext@(Extension appId) v =
|
||||
getUnversionedFileFromDir (rootDirectory </> appId </> show v) ext
|
||||
|
||||
-- /root/appId.ext
|
||||
getUnversionedFileFromDir :: KnownSymbol a => FilePath -> Extension a -> IO (Maybe FilePath)
|
||||
getUnversionedFileFromDir rootDirectory appExt = fmap (join . hush) . try @SomeException $ do
|
||||
dirContents <- listDirectory rootDirectory
|
||||
pure . fmap (rootDirectory </>) $ find (== show appExt) dirContents
|
||||
|
||||
newtype Extension (a :: Symbol) = Extension String deriving (Eq)
|
||||
type S9PK = Extension "s9pk"
|
||||
type SYS_EXTENSIONLESS = Extension ""
|
||||
type PNG = Extension "png"
|
||||
type SVG = Extension "svg"
|
||||
|
||||
instance IsString (Extension a) where
|
||||
fromString = Extension
|
||||
|
||||
def :: Extension a
|
||||
def = Extension ""
|
||||
|
||||
extension :: KnownSymbol a => Extension a -> String
|
||||
extension = symbolVal
|
||||
@@ -80,12 +27,6 @@ instance KnownSymbol a => Read (Extension a) where
|
||||
other -> [ (Extension file, "") | ext' == "" <.> other ]
|
||||
where (file, ext') = splitExtension s
|
||||
|
||||
withPeriod :: String -> String
|
||||
withPeriod word@(a : _) = case a of
|
||||
'.' -> word
|
||||
_ -> "." <> word
|
||||
withPeriod word = word
|
||||
|
||||
instance KnownSymbol a => PathPiece (Extension a) where
|
||||
fromPathPiece = readMaybe . toS
|
||||
toPathPiece = show
|
||||
|
||||
@@ -2,13 +2,13 @@
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
module Lib.Ssl where
|
||||
|
||||
import Startlude
|
||||
|
||||
import Data.String.Interpolate.IsString
|
||||
import System.Directory
|
||||
import System.Process
|
||||
|
||||
import Data.String.Interpolate.IsString
|
||||
|
||||
import Startlude
|
||||
|
||||
import Foundation
|
||||
import Settings
|
||||
|
||||
|
||||
@@ -1,20 +0,0 @@
|
||||
module Lib.SystemCtl where
|
||||
|
||||
import Startlude hiding ( words )
|
||||
import Protolude.Unsafe
|
||||
|
||||
import Data.String
|
||||
import System.Process
|
||||
import Text.Casing
|
||||
|
||||
data ServiceAction =
|
||||
StartService
|
||||
| StopService
|
||||
| RestartService
|
||||
deriving (Eq, Show)
|
||||
|
||||
toAction :: ServiceAction -> String
|
||||
toAction = fmap toLower . unsafeHead . words . wordify . show
|
||||
|
||||
systemCtl :: ServiceAction -> Text -> IO ExitCode
|
||||
systemCtl action service = rawSystem "systemctl" [toAction action, toS service]
|
||||
@@ -1,38 +1,49 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Lib.Types.AppIndex where
|
||||
|
||||
import Startlude hiding ( Any )
|
||||
|
||||
import Control.Monad.Fail
|
||||
import Data.Aeson
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import Startlude
|
||||
|
||||
import Control.Monad ( fail )
|
||||
import Data.Aeson ( (.:)
|
||||
, (.:?)
|
||||
, FromJSON(..)
|
||||
, FromJSONKey(..)
|
||||
, ToJSON(..)
|
||||
, ToJSONKey(..)
|
||||
, withObject
|
||||
)
|
||||
import qualified Data.ByteString.Lazy as BS
|
||||
import Data.Functor.Contravariant ( Contravariant(contramap) )
|
||||
import Data.Functor.Contravariant ( contramap )
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import Data.String.Interpolate.IsString
|
||||
-- import Model
|
||||
import qualified Data.Text as T
|
||||
import Database.Persist.Postgresql
|
||||
import qualified GHC.Read ( Read(..) )
|
||||
import qualified GHC.Show ( Show(..) )
|
||||
import Lib.Registry
|
||||
import Lib.Types.Emver
|
||||
import Database.Persist ( PersistField(..)
|
||||
, PersistValue(PersistText)
|
||||
, SqlType(..)
|
||||
)
|
||||
import Database.Persist.Sql ( PersistFieldSql(sqlType) )
|
||||
import GHC.Read ( Read(readsPrec) )
|
||||
import Lib.Types.Emver ( Version
|
||||
, VersionRange
|
||||
)
|
||||
import Orphans.Emver ( )
|
||||
import System.Directory
|
||||
import Yesod
|
||||
|
||||
import qualified Protolude.Base as P
|
||||
( Show(..) )
|
||||
import Web.HttpApiData ( FromHttpApiData
|
||||
, ToHttpApiData
|
||||
)
|
||||
import Yesod ( PathPiece(..) )
|
||||
newtype PkgId = PkgId { unPkgId :: Text }
|
||||
deriving (Eq)
|
||||
deriving stock (Eq, Ord)
|
||||
deriving newtype (FromHttpApiData, ToHttpApiData)
|
||||
instance IsString PkgId where
|
||||
fromString = PkgId . fromString
|
||||
instance Show PkgId where
|
||||
instance P.Show PkgId where
|
||||
show = toS . unPkgId
|
||||
instance Read PkgId where
|
||||
readsPrec _ s = [(PkgId $ toS s, "")]
|
||||
@@ -55,101 +66,15 @@ instance PersistFieldSql PkgId where
|
||||
instance PathPiece PkgId where
|
||||
fromPathPiece = fmap PkgId . fromPathPiece
|
||||
toPathPiece = unPkgId
|
||||
instance ToContent PkgId where
|
||||
toContent = toContent . toJSON
|
||||
instance ToTypedContent PkgId where
|
||||
toTypedContent = toTypedContent . toJSON
|
||||
|
||||
data VersionInfo = VersionInfo
|
||||
{ versionInfoVersion :: Version
|
||||
, versionInfoReleaseNotes :: Text
|
||||
, versionInfoDependencies :: HM.HashMap PkgId VersionRange
|
||||
, versionInfoOsRequired :: VersionRange
|
||||
, versionInfoOsRecommended :: VersionRange
|
||||
, versionInfoInstallAlert :: Maybe Text
|
||||
{ versionInfoVersion :: Version
|
||||
, versionInfoReleaseNotes :: Text
|
||||
, versionInfoDependencies :: HM.HashMap PkgId VersionRange
|
||||
, versionInfoOsVersion :: Version
|
||||
, versionInfoInstallAlert :: Maybe Text
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance Ord VersionInfo where
|
||||
compare = compare `on` versionInfoVersion
|
||||
|
||||
instance FromJSON VersionInfo where
|
||||
parseJSON = withObject "version info" $ \o -> do
|
||||
versionInfoVersion <- o .: "version"
|
||||
versionInfoReleaseNotes <- o .: "release-notes"
|
||||
versionInfoDependencies <- o .:? "dependencies" .!= HM.empty
|
||||
versionInfoOsRequired <- o .:? "os-version-required" .!= Any
|
||||
versionInfoOsRecommended <- o .:? "os-version-recommended" .!= Any
|
||||
versionInfoInstallAlert <- o .:? "install-alert"
|
||||
pure VersionInfo { .. }
|
||||
|
||||
instance ToJSON VersionInfo where
|
||||
toJSON VersionInfo {..} = object
|
||||
[ "version" .= versionInfoVersion
|
||||
, "release-notes" .= versionInfoReleaseNotes
|
||||
, "dependencies" .= versionInfoDependencies
|
||||
, "os-version-required" .= versionInfoOsRequired
|
||||
, "os-version-recommended" .= versionInfoOsRecommended
|
||||
, "install-alert" .= versionInfoInstallAlert
|
||||
]
|
||||
|
||||
data StoreApp = StoreApp
|
||||
{ storeAppTitle :: Text
|
||||
, storeAppDescShort :: Text
|
||||
, storeAppDescLong :: Text
|
||||
, storeAppVersionInfo :: NonEmpty VersionInfo
|
||||
, storeAppIconType :: Text
|
||||
, storeAppTimestamp :: Maybe UTCTime
|
||||
}
|
||||
deriving Show
|
||||
|
||||
instance ToJSON StoreApp where
|
||||
toJSON StoreApp {..} = object
|
||||
[ "title" .= storeAppTitle
|
||||
, "icon-type" .= storeAppIconType
|
||||
, "description" .= object ["short" .= storeAppDescShort, "long" .= storeAppDescLong]
|
||||
, "version-info" .= storeAppVersionInfo
|
||||
, "timestamp" .= storeAppTimestamp
|
||||
]
|
||||
newtype AppManifest = AppManifest { unAppManifest :: HM.HashMap PkgId StoreApp}
|
||||
deriving (Show)
|
||||
|
||||
instance FromJSON AppManifest where
|
||||
parseJSON = withObject "app details to seed" $ \o -> do
|
||||
apps <- for (HM.toList o) $ \(appId', c) -> do
|
||||
appId <- parseJSON $ String appId'
|
||||
config <- parseJSON c
|
||||
storeAppTitle <- config .: "title"
|
||||
storeAppIconType <- config .: "icon-type"
|
||||
storeAppDescShort <- config .: "description" >>= (.: "short")
|
||||
storeAppDescLong <- config .: "description" >>= (.: "long")
|
||||
storeAppVersionInfo <- config .: "version-info" >>= \case
|
||||
[] -> fail "No Valid Version Info"
|
||||
(x : xs) -> pure $ x :| xs
|
||||
storeAppTimestamp <- config .:? "timestamp"
|
||||
pure (appId, StoreApp { .. })
|
||||
return $ AppManifest (HM.fromList apps)
|
||||
instance ToJSON AppManifest where
|
||||
toJSON = toJSON . unAppManifest
|
||||
|
||||
filterOsRequired :: Version -> StoreApp -> Maybe StoreApp
|
||||
filterOsRequired av sa = case NE.filter ((av <||) . versionInfoOsRequired) (storeAppVersionInfo sa) of
|
||||
[] -> Nothing
|
||||
(x : xs) -> Just $ sa { storeAppVersionInfo = x :| xs }
|
||||
|
||||
filterOsRecommended :: Version -> StoreApp -> Maybe StoreApp
|
||||
filterOsRecommended av sa = case NE.filter ((av <||) . versionInfoOsRecommended) (storeAppVersionInfo sa) of
|
||||
[] -> Nothing
|
||||
(x : xs) -> Just $ sa { storeAppVersionInfo = x :| xs }
|
||||
|
||||
addFileTimestamp :: KnownSymbol a => FilePath -> Extension a -> StoreApp -> Version -> IO (Maybe StoreApp)
|
||||
addFileTimestamp appDir ext service v = do
|
||||
getVersionedFileFromDir appDir ext v >>= \case
|
||||
Nothing -> pure Nothing
|
||||
Just file -> do
|
||||
time <- getModificationTime file
|
||||
pure $ Just service { storeAppTimestamp = Just time }
|
||||
|
||||
data ServiceDependencyInfo = ServiceDependencyInfo
|
||||
{ serviceDependencyInfoOptional :: Maybe Text
|
||||
, serviceDependencyInfoVersion :: VersionRange
|
||||
@@ -164,27 +89,8 @@ instance FromJSON ServiceDependencyInfo where
|
||||
serviceDependencyInfoDescription <- o .:? "description"
|
||||
serviceDependencyInfoCritical <- o .: "critical"
|
||||
pure ServiceDependencyInfo { .. }
|
||||
instance ToJSON ServiceDependencyInfo where
|
||||
toJSON ServiceDependencyInfo {..} = object
|
||||
[ "description" .= serviceDependencyInfoDescription
|
||||
, "version" .= serviceDependencyInfoVersion
|
||||
, "optional" .= serviceDependencyInfoOptional
|
||||
, "critical" .= serviceDependencyInfoCritical
|
||||
]
|
||||
data ServiceAlert = INSTALL | UNINSTALL | RESTORE | START | STOP
|
||||
deriving (Show, Eq, Generic, Hashable, Read)
|
||||
instance FromJSONKey ServiceAlert
|
||||
instance ToJSONKey ServiceAlert
|
||||
instance ToJSON ServiceAlert where
|
||||
toJSON = String . T.toLower . show
|
||||
instance FromJSON ServiceAlert where
|
||||
parseJSON = withText "ServiceAlert" $ \case
|
||||
"install" -> pure INSTALL
|
||||
"uninstall" -> pure UNINSTALL
|
||||
"restore" -> pure RESTORE
|
||||
"start" -> pure START
|
||||
"stop" -> pure STOP
|
||||
_ -> fail "unknown service alert type"
|
||||
data ServiceManifest = ServiceManifest
|
||||
{ serviceManifestId :: !PkgId
|
||||
, serviceManifestTitle :: !Text
|
||||
@@ -216,16 +122,6 @@ instance FromJSON ServiceManifest where
|
||||
let serviceManifestAlerts = HM.fromList a
|
||||
serviceManifestDependencies <- o .: "dependencies"
|
||||
pure ServiceManifest { .. }
|
||||
instance ToJSON ServiceManifest where
|
||||
toJSON ServiceManifest {..} = object
|
||||
[ "id" .= serviceManifestId
|
||||
, "title" .= serviceManifestTitle
|
||||
, "version" .= serviceManifestVersion
|
||||
, "description" .= object ["short" .= serviceManifestDescriptionShort, "long" .= serviceManifestDescriptionLong]
|
||||
, "release-notes" .= serviceManifestReleaseNotes
|
||||
, "alerts" .= object [ t .= v | (k, v) <- HM.toList serviceManifestAlerts, let (String t) = toJSON k ]
|
||||
, "dependencies" .= serviceManifestDependencies
|
||||
]
|
||||
|
||||
-- >>> eitherDecode testManifest :: Either String ServiceManifest
|
||||
-- Right (ServiceManifest {serviceManifestId = embassy-pages, serviceManifestTitle = "Embassy Pages", serviceManifestVersion = 0.1.3, serviceManifestDescriptionLong = "Embassy Pages is a simple web server that uses directories inside File Browser to serve Tor websites.", serviceManifestDescriptionShort = "Create Tor websites, hosted on your Embassy.", serviceManifestReleaseNotes = "Upgrade to EmbassyOS v0.3.0", serviceManifestIcon = Just "icon.png", serviceManifestAlerts = fromList [(INSTALL,Nothing),(UNINSTALL,Nothing),(STOP,Nothing),(RESTORE,Nothing),(START,Nothing)], serviceManifestDependencies = fromList [(filebrowser,ServiceDependencyInfo {serviceDependencyInfoOptional = Nothing, serviceDependencyInfoVersion = >=2.14.1.1 <3.0.0, serviceDependencyInfoDescription = Just "Used to upload files to serve.", serviceDependencyInfoCritical = False})]})
|
||||
|
||||
@@ -1,6 +0,0 @@
|
||||
module Lib.Types.FileSystem where
|
||||
|
||||
import Startlude
|
||||
|
||||
data FileExistence = Existent | NonExistent
|
||||
deriving (Eq, Show)
|
||||
32
src/Model.hs
32
src/Model.hs
@@ -1,4 +1,6 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
@@ -6,7 +8,6 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
|
||||
module Model where
|
||||
|
||||
@@ -18,44 +19,42 @@ import Orphans.Emver ( )
|
||||
import Startlude
|
||||
|
||||
share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
|
||||
SApp
|
||||
PkgRecord
|
||||
Id PkgId sql=pkg_id
|
||||
createdAt UTCTime
|
||||
updatedAt UTCTime Maybe
|
||||
title Text
|
||||
appId PkgId
|
||||
descShort Text
|
||||
descLong Text
|
||||
iconType Text
|
||||
UniqueAppId appId
|
||||
deriving Eq
|
||||
deriving Show
|
||||
|
||||
SVersion sql=version
|
||||
VersionRecord sql=version
|
||||
createdAt UTCTime
|
||||
updatedAt UTCTime Maybe
|
||||
appId SAppId
|
||||
pkgId PkgRecordId
|
||||
number Version
|
||||
releaseNotes Text
|
||||
osVersionRequired VersionRange default='*'
|
||||
osVersionRecommended VersionRange default='*'
|
||||
osVersion Version
|
||||
arch Text Maybe
|
||||
UniqueBin appId number
|
||||
Primary pkgId number
|
||||
deriving Eq
|
||||
deriving Show
|
||||
|
||||
OsVersion
|
||||
OsVersion
|
||||
createdAt UTCTime
|
||||
updatedAt UTCTime
|
||||
number Version
|
||||
headline Text
|
||||
releaseNotes Text
|
||||
releaseNotes Text
|
||||
deriving Eq
|
||||
deriving Show
|
||||
|
||||
Metric
|
||||
createdAt UTCTime
|
||||
appId SAppId
|
||||
version SVersionId
|
||||
pkgId PkgRecordId
|
||||
version VersionRecordId
|
||||
deriving Eq
|
||||
deriving Show
|
||||
|
||||
@@ -69,13 +68,10 @@ Category
|
||||
deriving Eq
|
||||
deriving Show
|
||||
|
||||
ServiceCategory
|
||||
PkgCategory
|
||||
createdAt UTCTime
|
||||
serviceId SAppId
|
||||
pkgId PkgRecordId
|
||||
categoryId CategoryId
|
||||
serviceName Text -- SAppAppId
|
||||
categoryName CategoryTitle -- CategoryTitle
|
||||
priority Int Maybe
|
||||
deriving Eq
|
||||
deriving Show
|
||||
|]
|
||||
|
||||
@@ -1,13 +0,0 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
module Orphans.Yesod where
|
||||
|
||||
import Startlude
|
||||
|
||||
import Yesod.Core
|
||||
|
||||
-- | Forgive me for I have sinned
|
||||
instance ToJSON a => ToContent [a] where
|
||||
toContent = toContent . toJSON . fmap toJSON
|
||||
instance ToJSON a => ToTypedContent [a] where
|
||||
toTypedContent = toTypedContent . toJSON . fmap toJSON
|
||||
|
||||
@@ -1,12 +1,10 @@
|
||||
module Startlude
|
||||
( module X
|
||||
, module Startlude
|
||||
)
|
||||
where
|
||||
) where
|
||||
|
||||
import Control.Arrow as X
|
||||
( (&&&) )
|
||||
-- import Control.Comonad as X
|
||||
import Control.Error.Util as X
|
||||
import Data.Coerce as X
|
||||
import Data.String as X
|
||||
@@ -15,14 +13,14 @@ import Data.String as X
|
||||
)
|
||||
import Data.Time.Clock as X
|
||||
import Protolude as X
|
||||
hiding ( bool
|
||||
hiding ( (<.>)
|
||||
, bool
|
||||
, hush
|
||||
, isLeft
|
||||
, isRight
|
||||
, note
|
||||
, readMaybe
|
||||
, tryIO
|
||||
, (<.>)
|
||||
)
|
||||
import qualified Protolude as P
|
||||
( readMaybe )
|
||||
|
||||
@@ -1,26 +0,0 @@
|
||||
module Util.Function where
|
||||
|
||||
import Startlude
|
||||
|
||||
(.*) :: (b -> c) -> (a0 -> a1 -> b) -> a0 -> a1 -> c
|
||||
(.*) = (.) . (.)
|
||||
|
||||
(.**) :: (b -> c) -> (a0 -> a1 -> a2 -> b) -> a0 -> a1 -> a2 -> c
|
||||
(.**) = (.) . (.*)
|
||||
|
||||
preimage :: Eq b => (a -> b) -> b -> [a] -> [a]
|
||||
preimage f target = filter ((== target) . f)
|
||||
|
||||
mapFind :: ([a] -> Maybe a) -> (b -> a) -> [b] -> Maybe b
|
||||
mapFind _ _ [] = Nothing
|
||||
mapFind finder mapping (b : bs) =
|
||||
let mB = mapFind finder mapping bs
|
||||
mA = finder [mapping b]
|
||||
in case (mB, mA) of
|
||||
(Just b', _ ) -> Just b'
|
||||
(Nothing, Just _) -> Just b
|
||||
_ -> Nothing
|
||||
|
||||
(<<&>>) :: (Functor f, Functor g) => f (g a) -> (a -> b) -> f (g b)
|
||||
f <<&>> fab = fmap (fmap fab) f
|
||||
|
||||
@@ -1,4 +1,3 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
|
||||
module Util.Shared where
|
||||
|
||||
Reference in New Issue
Block a user