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

package.yaml

@@ -32,6 +32,7 @@ dependencies:
   - filepath
   - foreign-store
   - fsnotify
+  - http-api-data
   - http-types
   - interpolate
   - lens

src/Database/Marketplace.hs

@@ -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 :: (MonadResource m, MonadIO m)
-searchServices Nothing pageItems offset' query = select $ do
+               => Maybe CategoryTitle
-    service <- from $ table @SApp
+               -> Text
+               -> ConduitT () (Entity PkgRecord) (ReaderT SqlBackend m) ()
+searchServices Nothing query = selectSource $ do
+    service <- from $ table @PkgRecord
     where_
-        (   (service ^. SAppDescShort `ilike` (%) ++. val query ++. (%))
+        (   (service ^. PkgRecordDescShort `ilike` (%) ++. val query ++. (%))
-        ||. (service ^. SAppDescLong `ilike` (%) ++. val query ++. (%))
+        ||. (service ^. PkgRecordDescLong `ilike` (%) ++. val query ++. (%))
-        ||. (service ^. SAppTitle `ilike` (%) ++. val query ++. (%))
+        ||. (service ^. PkgRecordTitle `ilike` (%) ++. val query ++. (%))
         )
-    orderBy [desc (service ^. SAppUpdatedAt)]
+    orderBy [desc (service ^. PkgRecordUpdatedAt)]
-    limit pageItems
-    offset offset'
     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
+                $           table @PkgRecord
-                `innerJoin` table @ServiceCategory
+                `innerJoin` table @PkgCategory
-                `on`        (\(s :& sc) -> sc ^. ServiceCategoryServiceId ==. s ^. SAppId)
+                `on`        (\(s :& sc) -> sc ^. PkgCategoryPkgId ==. s ^. PkgRecordId)
-                        -- if there is a cateogry, only search in category
+                `innerJoin` table @Category
-                        -- weight title, short, long (bitcoin should equal Bitcoin Core)
+                `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
+                $   cat
-                ^.  ServiceCategoryCategoryName
+                ^.  CategoryName
                 ==. val category
-                &&. (   (service ^. SAppDescShort `ilike` (%) ++. val query ++. (%))
+                &&. (   (service ^. PkgRecordDescShort `ilike` (%) ++. val query ++. (%))
-                    ||. (service ^. SAppDescLong `ilike` (%) ++. val query ++. (%))
+                    ||. (service ^. PkgRecordDescLong `ilike` (%) ++. val query ++. (%))
-                    ||. (service ^. SAppTitle `ilike` (%) ++. val query ++. (%))
+                    ||. (service ^. PkgRecordTitle `ilike` (%) ++. val query ++. (%))
                     )
             pure service
         )
-    orderBy [desc (services ^. SAppUpdatedAt)]
+    orderBy [desc (services ^. PkgRecordUpdatedAt)]
-    limit pageItems
-    offset offset'
     pure services
 
-newtype VersionsWithReleaseNotes = VersionsWithReleaseNotes (HashMap Version Text) deriving (Eq, Show, Generic)
+getPkgData :: (MonadResource m, MonadIO m) => [PkgId] -> ConduitT () (Entity PkgRecord) (ReaderT SqlBackend m) ()
-instance FromJSON VersionsWithReleaseNotes
+getPkgData pkgs = selectSource $ do
-instance PersistField VersionsWithReleaseNotes where
+    pkgData <- from $ table @PkgRecord
-    fromPersistValue = fromPersistValueJSON
+    where_ (pkgData ^. PkgRecordId `in_` valList (PkgRecordKey <$> pkgs))
-    toPersistValue   = PersistText . show
+    pure pkgData
 
--- in progress attempt to do postgres aggregation with raw sql in esqueleto
+zipVersions :: MonadUnliftIO m
--- getServiceVersionsWithReleaseNotes :: MonadIO m => Text -> ReaderT SqlBackend m (Entity SApp)
+            => ConduitT (Entity PkgRecord) (Entity PkgRecord, [Entity VersionRecord]) (ReaderT SqlBackend m) ()
--- 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 = 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)

src/Database/Queries.hs

@@ -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 :: MonadIO m => PkgId -> ReaderT SqlBackend m (Maybe PkgRecord)
-fetchApp appId = selectFirst [SAppAppId ==. appId] []
+fetchApp = get . PkgRecordKey
 
-fetchAppVersion :: MonadIO m => Version -> Key SApp -> ReaderT SqlBackend m (Maybe (Entity SVersion))
+fetchAppVersion :: MonadIO m => PkgId -> Version -> ReaderT SqlBackend m (Maybe VersionRecord)
-fetchAppVersion appVersion appId = selectFirst [SVersionNumber ==. appVersion, SVersionAppId ==. appId] []
+fetchAppVersion pkgId version = get (VersionRecordKey (PkgRecordKey pkgId) version)
 
-createApp :: MonadIO m => PkgId -> StoreApp -> ReaderT SqlBackend m (Maybe (Key SApp))
+createMetric :: MonadIO m => PkgId -> Version -> ReaderT SqlBackend m ()
-createApp appId StoreApp {..} = do
+createMetric appId version = do
     time <- liftIO getCurrentTime
-    insertUnique $ SApp time Nothing storeAppTitle appId storeAppDescShort storeAppDescLong storeAppIconType
+    insert_ $ Metric time (PkgRecordKey appId) (VersionRecordKey (PkgRecordKey appId) version)
-
-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

src/Foundation.hs

@@ -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) }
 
 
 

src/Handler/Apps.hs

@@ -11,16 +11,8 @@ module Handler.Apps where
 
 import           Startlude               hiding ( Handler )
 
-import           Control.Monad.Logger           ( logError
+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 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
+import           Lib.Types.Emver                ( Version )
-                                                , parseVersion
-                                                )
-import           Network.Wai                    ( Request(requestHeaderUserAgent) )
 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
+        Just _ -> do
-            let appKey' = entityKey a
+            existingVersion <- runDB $ fetchAppVersion pkg appVersion
-            existingVersion <- runDB $ fetchAppVersion appVersion appKey'
             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
 

src/Handler/Icons.hs

@@ -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

src/Handler/Marketplace.hs

@@ -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           ( filterOsCompatible
-import           Database.Marketplace           ( searchServices )
+                                                , 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(..)
+                                                , PkgCategory
-                                                , SVersion(..)
+                                                , PkgRecord(..)
-                                                , ServiceCategory
+                                                , 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
+import           UnliftIO.Async                 ( mapConcurrently )
-                                                , mapConcurrently
-                                                )
 import           UnliftIO.Directory             ( listDirectory )
-import           Util.Shared                    ( getVersionSpecFromQuery
+import           Util.Shared                    ( getVersionSpecFromQuery )
-                                                , orThrow
+import           Yesod.Core                     ( MonadResource
-                                                )
-import           Yesod.Core                     ( HandlerFor
-                                                , MonadLogger
-                                                , MonadResource
-                                                , MonadUnliftIO
                                                 , 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
+    , serviceListPageLimit  :: Int -- the number of items per page
-    , serviceListPageNumber :: Int64 -- the page you are on
+    , 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
+            (_, notes) <- fetchAllAppVersions (PkgId package)
-                status404
+            pure notes
-                (NotFoundE $ show package)
-            (_, mappedVersions) <- fetchAllAppVersions (entityKey service)
-            pure mappedVersions
 
 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)
+            Left  _ -> sendResponseStatus status400 (InvalidParamsE "get:ids" packages)
-            Right (p :: [PkgId]) -> do
+            Right p -> do
-                let packageList :: [(PkgId, Maybe Version)] = (, Nothing) <$> p
+                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
+    osPredicate <- getOsVersionQuery <&> \case
-    case pkgIds of
+        Nothing -> const True
+        Just v  -> flip satisfies v
+    pkgIds           <- getPkgIdsQuery
+    filteredServices <- case pkgIds of
         Nothing -> do
             -- query for all
-            category         <- getCategoryQuery
+            category <- getCategoryQuery
-            page             <- getPageQuery
+            page     <- getPageQuery
-            limit'           <- getLimitQuery
+            limit'   <- getLimitQuery
-            query            <- T.strip . fromMaybe (serviceListQuery defaults) <$> lookupGetParam "query"
+            query    <- T.strip . fromMaybe (serviceListQuery defaults) <$> lookupGetParam "query"
-            filteredServices <- runDB $ searchServices category limit' ((page - 1) * limit') query
+            runDB
-            let filteredServices' = sAppAppId . entityVal <$> filteredServices
+                $  runConduit
-            settings            <- getsYesod appSettings
+                $  searchServices category query
-            packageMetadata     <- runDB $ fetchPackageMetadata
+                .| zipVersions
-            serviceDetailResult <- mapConcurrently (getServiceDetails settings packageMetadata Nothing)
+                .| filterOsCompatible osPredicate
-                                                   filteredServices'
+                -- pages start at 1 for some reason. TODO: make pages start at 0
-            let (_, services) = partitionEithers serviceDetailResult
+                .| (dropC (limit' * (page - 1)) *> takeC limit')
-            pure $ ServiceAvailableRes services
+                .| sinkList
-
         Just packages -> do
-                -- for each item in list get best available from version range
+            -- for each item in list get best available from version range
-            settings                <- getsYesod appSettings
+            let vMap = (packageVersionId &&& packageVersionVersion) <$> packages
-            -- @TODO fix _ error
+            runDB
-            packageMetadata         <- runDB $ fetchPackageMetadata
+                .  runConduit
-            availableServicesResult <- traverse (getPackageDetails packageMetadata) packages
+                $  getPkgData (packageVersionId <$> packages)
-            let (_, availableServices) = partitionEithers availableServicesResult
+                .| zipVersions
-            serviceDetailResult <- mapConcurrently (uncurry $ getServiceDetails settings packageMetadata)
+                .| mapC
-                                                   availableServices
+                       (\(a, vs) ->
-            -- @TODO fix _ error
+                           let spec = fromMaybe Any $ lookup (unPkgRecordKey $ entityKey a) vMap
-            let (_, services) = partitionEithers serviceDetailResult
+                           in  (a, filter ((<|| spec) . versionRecordNumber . entityVal) vs)
-            pure $ ServiceAvailableRes services
+                       )
+                .| 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
+        getOsVersionQuery :: Handler (Maybe VersionRange)
-                          => (HM.HashMap PkgId ([Version], [CategoryTitle]))
+        getOsVersionQuery = lookupGetParam "eos-version-range" >>= \case
-                          -> PackageVersion
+            Nothing  -> pure Nothing
-                          -> m (Either Text ((Maybe Version), PkgId))
+            Just osv -> case Atto.parseOnly parseRange osv of
-        getPackageDetails metadata pv = do
+                Left _ -> do
-            let appId = packageVersionId pv
+                    let e = InvalidParamsE "get:eos-version-range" osv
-            let spec  = packageVersionVersion pv
+                    $logWarn (show e)
-            pacakgeMetadata <- case HM.lookup appId metadata of
+                    sendResponseStatus status400 e
-                Nothing -> throwIO $ NotFoundE [i|dependency metadata for #{appId} not found.|]
+                Right v -> pure $ Just v
-                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)
 
-getServiceDetails :: (MonadIO m, MonadResource m)
+getServiceDetails :: (MonadIO m, MonadResource m, MonadReader r m, Has AppSettings r)
-                  => AppSettings
+                  => (HM.HashMap PkgId ([Version], [CategoryTitle]))
-                  -> (HM.HashMap PkgId ([Version], [CategoryTitle]))
-                  -> Maybe Version
                   -> 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
+            (\v -> VersionInfo { versionInfoVersion      = versionRecordNumber v
-                               , versionInfoReleaseNotes  = sVersionReleaseNotes v
+                               , versionInfoReleaseNotes = versionRecordReleaseNotes v
-                               , versionInfoDependencies  = HM.empty
+                               , versionInfoDependencies = HM.empty
-                               , versionInfoOsRequired    = sVersionOsVersionRequired v
+                               , versionInfoOsVersion    = versionRecordOsVersion v
-                               , versionInfoOsRecommended = sVersionOsVersionRecommended v
+                               , versionInfoInstallAlert = Nothing
-                               , 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
+        $           table @PkgRecord
-        `innerJoin` table @SVersion
+        `innerJoin` table @VersionRecord
-        `on`        (\(service :& version) -> service ^. SAppId ==. version ^. SVersionAppId)
+        `on`        (\(service :& version) -> service ^. PkgRecordId ==. version ^. VersionRecordPkgId)
-    where_ (service ^. SAppAppId ==. val appId)
+    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

src/Handler/Types/Status.hs

@@ -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

src/Handler/Version.hs

@@ -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

src/Lib/Error.hs

@@ -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

src/Lib/Registry.hs

@@ -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

src/Lib/Ssl.hs

@@ -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
 

src/Lib/SystemCtl.hs

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

src/Lib/Types/AppIndex.hs

@@ -1,38 +1,49 @@
-{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE GeneralisedNewtypeDeriving #-}
+{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE QuasiQuotes #-}
-
 module Lib.Types.AppIndex where
 
-import           Startlude               hiding ( Any )
+import           Startlude
-
-import           Control.Monad.Fail
-import           Data.Aeson
-import qualified Data.HashMap.Strict           as HM
-import qualified Data.List.NonEmpty            as NE
 
+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           Database.Persist               ( PersistField(..)
-import qualified GHC.Read                       ( Read(..) )
+                                                , PersistValue(PersistText)
-import qualified GHC.Show                       ( Show(..) )
+                                                , SqlType(..)
-import           Lib.Registry
+                                                )
-import           Lib.Types.Emver
+import           Database.Persist.Sql           ( PersistFieldSql(sqlType) )
+import           GHC.Read                       ( Read(readsPrec) )
+import           Lib.Types.Emver                ( Version
+                                                , VersionRange
+                                                )
 import           Orphans.Emver                  ( )
-import           System.Directory
+import qualified Protolude.Base                as P
-import           Yesod
+                                                ( 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
+    { versionInfoVersion      :: Version
-    , versionInfoReleaseNotes  :: Text
+    , versionInfoReleaseNotes :: Text
-    , versionInfoDependencies  :: HM.HashMap PkgId VersionRange
+    , versionInfoDependencies :: HM.HashMap PkgId VersionRange
-    , versionInfoOsRequired    :: VersionRange
+    , versionInfoOsVersion    :: Version
-    , versionInfoOsRecommended :: VersionRange
+    , versionInfoInstallAlert :: Maybe Text
-    , 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})]})

src/Lib/Types/FileSystem.hs

@@ -1,6 +0,0 @@
-module Lib.Types.FileSystem where
-
-    import           Startlude
-
-    data FileExistence = Existent | NonExistent
-        deriving (Eq, Show)

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,28 +19,26 @@ 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='*'
+    osVersion Version
-    osVersionRecommended VersionRange default='*'
     arch Text Maybe
-    UniqueBin appId number
+    Primary pkgId number
     deriving Eq
     deriving Show
 
@@ -54,8 +53,8 @@ OsVersion
 
 Metric
     createdAt UTCTime
-    appId SAppId
+    pkgId PkgRecordId
-    version SVersionId
+    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
 |]

src/Orphans/Yesod.hs

@@ -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
-

src/Startlude.hs

@@ -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 )

src/Util/Function.hs

@@ -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
-

src/Util/Shared.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE TemplateHaskell  #-}
 {-# LANGUAGE FlexibleContexts #-}
 
 module Util.Shared where

test/Handler/MarketplaceSpec.hs

@@ -2,18 +2,21 @@
 
 module Handler.MarketplaceSpec
     ( spec
-    )
+    ) where
-where
 
-import           Startlude               hiding ( Any )
-import           Database.Persist.Sql
 import           Data.Maybe
+import           Database.Persist.Sql
+import           Startlude               hiding ( Any )
 
-import           TestImport
+import           Conduit                        ( (.|)
-import           Model
+                                                , runConduit
+                                                , sinkList
+                                                )
 import           Database.Marketplace
 import           Lib.Types.Category
 import           Lib.Types.Emver
+import           Model
+import           TestImport
 
 spec :: Spec
 spec = do
@@ -40,7 +43,7 @@ spec = do
         _           <- runDBtest $ insert_ $ ServiceCategory time lnd lnCat "lnd" LIGHTNING Nothing
         _           <- runDBtest $ insert_ $ ServiceCategory time lnd btcCat "lnd" BITCOIN Nothing
         _           <- runDBtest $ insert_ $ ServiceCategory time btc btcCat "bitcon" BITCOIN Nothing
-        apps        <- runDBtest $ searchServices (Just FEATURED) 20 0 ""
+        apps        <- runDBtest $ runConduit $ searchServices (Just FEATURED) "" .| sinkList
         assertEq "should exist" (length apps) 1
         let app' = fromJust $ head apps
         assertEq "should be bitcoin" (sAppTitle $ entityVal app') "Bitcoin Core"
@@ -67,7 +70,7 @@ spec = do
         _           <- runDBtest $ insert_ $ ServiceCategory time lnd lnCat "lnd" LIGHTNING Nothing
         _           <- runDBtest $ insert_ $ ServiceCategory time lnd btcCat "lnd" BITCOIN Nothing
         _           <- runDBtest $ insert_ $ ServiceCategory time btc btcCat "bitcoind" BITCOIN Nothing
-        apps        <- runDBtest $ searchServices (Just BITCOIN) 20 0 ""
+        apps        <- runDBtest $ runConduit $ searchServices (Just BITCOIN) "" .| sinkList
         assertEq "should exist" (length apps) 2
     describe "searchServices with fuzzy query"
         $ withApp
@@ -91,7 +94,7 @@ spec = do
               cate <- runDBtest $ insert $ Category time FEATURED Nothing "desc" 0
               _    <- runDBtest $ insert_ $ ServiceCategory time app1 cate "bitcoind" FEATURED Nothing
               _    <- runDBtest $ insert_ $ ServiceCategory time app2 cate "lnd" FEATURED Nothing
-              apps <- runDBtest $ searchServices (Just FEATURED) 20 0 "lightning"
+              apps <- runDBtest $ runConduit $ searchServices (Just FEATURED) "lightning" .| sinkList
               assertEq "should exist" (length apps) 1
               let app' = fromJust $ head apps
               print app'
@@ -123,14 +126,5 @@ spec = do
         _           <- runDBtest $ insert_ $ ServiceCategory time lnd lnCat "lnd" LIGHTNING Nothing
         _           <- runDBtest $ insert_ $ ServiceCategory time lnd btcCat "lnd" BITCOIN Nothing
         _           <- runDBtest $ insert_ $ ServiceCategory time btc btcCat "bitcon" BITCOIN Nothing
-        apps        <- runDBtest $ searchServices Nothing 20 0 ""
+        apps        <- runDBtest $ runConduit $ searchServices Nothing "" .| sinkList
         assertEq "should exist" (length apps) 2
-    xdescribe "getServiceVersionsWithReleaseNotes"
-        $ withApp
-        $ it "gets service with mapping of version to release notes"
-        $ do
-              time <- liftIO getCurrentTime
-              app  <- runDBtest $ insert $ SApp time Nothing "Bitcoin Core" "bitcoin" "short desc" "long desc" "png"
-              _    <- runDBtest $ insert $ SVersion time Nothing app "0.19.0.0" "release notes 0.19.0.0" Any Any Nothing
-              _    <- runDBtest $ insert $ SVersion time Nothing app "0.20.0.0" "release notes 0.19.0.0" Any Any Nothing
-              print ()