diff --git a/.gitignore b/.gitignore index 4e52e74..ce60388 100644 --- a/.gitignore +++ b/.gitignore @@ -28,4 +28,5 @@ agent_* agent.* version **/*.s9pk -**/appmgr \ No newline at end of file +**/appmgr +0.3.0_features.md \ No newline at end of file diff --git a/app/DevelMain.hs b/app/DevelMain.hs new file mode 100644 index 0000000..bf86185 --- /dev/null +++ b/app/DevelMain.hs @@ -0,0 +1,106 @@ +module DevelMain where + +import Prelude +import Application (getApplicationRepl, shutdownApp) + +import Control.Monad ((>=>)) +import Control.Concurrent +import Data.IORef +import Foreign.Store +import Network.Wai.Handler.Warp +import GHC.Word + + +-- | Running your app inside GHCi. +-- +-- This option provides significantly faster code reload compared to +-- @yesod devel@. However, you do not get automatic code reload +-- (which may be a benefit, depending on your perspective). To use this: +-- +-- 1. Start up GHCi +-- +-- $ stack ghci eos-image-server:lib --no-load --work-dir .stack-work-devel +-- +-- 2. Load this module +-- +-- > :l app/DevelMain.hs +-- +-- 3. Run @update@ +-- +-- > DevelMain.update +-- +-- 4. Your app should now be running, you can connect at http://localhost:3000 +-- +-- 5. Make changes to your code +-- +-- 6. After saving your changes, reload by running: +-- +-- > :r +-- > DevelMain.update +-- +-- You can also call @DevelMain.shutdown@ to stop the app +-- +-- There is more information about this approach, +-- on the wiki: https://github.com/yesodweb/yesod/wiki/ghci +-- +-- WARNING: GHCi does not notice changes made to your template files. +-- If you change a template, you'll need to either exit GHCi and reload, +-- or manually @touch@ another Haskell module. + +-- | Start or restart the server. +-- newStore is from foreign-store. +-- A Store holds onto some data across ghci reloads +update :: IO () +update = do + mtidStore <- lookupStore tidStoreNum + case mtidStore of + -- no server running + Nothing -> do + done <- storeAction doneStore newEmptyMVar + tid <- start done + _ <- storeAction (Store tidStoreNum) (newIORef tid) + return () + -- server is already running + Just tidStore -> restartAppInNewThread tidStore + where + doneStore :: Store (MVar ()) + doneStore = Store 0 + + -- shut the server down with killThread and wait for the done signal + restartAppInNewThread :: Store (IORef ThreadId) -> IO () + restartAppInNewThread tidStore = modifyStoredIORef tidStore $ \tid -> do + killThread tid + withStore doneStore takeMVar + readStore doneStore >>= start + + + -- | Start the server in a separate thread. + start :: MVar () -- ^ Written to when the thread is killed. + -> IO ThreadId + start done = do + (port, site, app) <- getApplicationRepl + forkFinally + (runSettings (setPort port defaultSettings) app) + -- Note that this implies concurrency + -- between shutdownApp and the next app that is starting. + -- Normally this should be fine + (\_ -> putMVar done () >> shutdownApp site) + +-- | kill the server +shutdown :: IO () +shutdown = do + mtidStore <- lookupStore tidStoreNum + case mtidStore of + -- no server running + Nothing -> putStrLn "no Yesod app running" + Just tidStore -> do + withStore tidStore $ readIORef >=> killThread + putStrLn "Yesod app is shutdown" + +tidStoreNum :: Word32 +tidStoreNum = 1 + +modifyStoredIORef :: Store (IORef a) -> (a -> IO a) -> IO () +modifyStoredIORef store f = withStore store $ \ref -> do + v <- readIORef ref + f v >>= writeIORef ref diff --git a/app/devel.hs b/app/devel.hs new file mode 100644 index 0000000..efc07ae --- /dev/null +++ b/app/devel.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE PackageImports #-} +import "start9-registry" Application (develMain) +import Prelude (IO) + +main :: IO () +main = develMain \ No newline at end of file diff --git a/config/routes b/config/routes index 99210a6..28d0c25 100644 --- a/config/routes +++ b/config/routes @@ -13,4 +13,7 @@ !/apps/#S9PK AppR GET -- get most recent appId at appversion spec, defaults to >=0.0.0 -- ?spec={semver-spec} /sys/status SystemStatusR GET -- get system update status and version -!/sys/#SYS_EXTENSIONLESS SysR GET -- get most recent sys app -- ?spec={semver-spec} \ No newline at end of file +!/sys/#SYS_EXTENSIONLESS SysR GET -- get most recent sys app -- ?spec={semver-spec} +/marketplace/data CategoriesR GET -- get all marketplace categories +/marketplace/available/list ServiceListR GET -- filter marketplace services by various query params +/marketplace/available ServiceR GET -- get service information \ No newline at end of file diff --git a/config/settings.yml b/config/settings.yml index 6b4d3c2..b3caa79 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -18,7 +18,7 @@ ip-from-header: "_env:YESOD_IP_FROM_HEADER:false" # Optional values with the following production defaults. # In development, they default to the inverse. # -# detailed-logging: false +detailed-logging: true # should-log-all: false # reload-templates: false # mutable-static: false @@ -31,7 +31,7 @@ ip-from-header: "_env:YESOD_IP_FROM_HEADER:false" resources-path: "_env:RESOURCES_PATH:/var/www/html/resources" ssl-path: "_env:SSL_PATH:/var/ssl" ssl-auto: "_env:SSL_AUTO:true" -registry-hostname: "_env:REGISTRY_HOSTNAME:registry.start9labs.com" +registry-hostname: "_env:REGISTRY_HOSTNAME:alpha-registry.start9labs.com" tor-port: "_env:TOR_PORT:447" static-bin-dir: "_env:STATIC_BIN:/usr/local/bin/" diff --git a/package.yaml b/package.yaml index 2c796a4..d82d6f5 100644 --- a/package.yaml +++ b/package.yaml @@ -53,6 +53,9 @@ dependencies: - yesod - yesod-core - yesod-persistent +- esqueleto +- text-conversions +- foreign-store library: source-dirs: src diff --git a/src/Application.hs b/src/Application.hs index 845790a..1714ab5 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -11,6 +11,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Application ( appMain + , develMain , makeFoundation , makeLogWare , shutdownApp @@ -25,7 +26,7 @@ module Application , handler ) where -import Startlude +import Startlude hiding (Handler) import Control.Monad.Logger (liftLoc, runLoggingT) import Data.Default @@ -53,6 +54,7 @@ import Foundation import Handler.Apps import Handler.Icons import Handler.Version +import Handler.Marketplace import Lib.Ssl import Settings import System.Posix.Process @@ -310,16 +312,32 @@ shutdownWeb RegistryCtx{..} = do -- Functions for DevelMain.hs (a way to run the RegistryCtx from GHCi) -------------------------------------------------------------- -getApplicationRepl :: AppPort -> IO (Int, RegistryCtx, Application) -getApplicationRepl port = do +getApplicationRepl :: IO (Int, RegistryCtx, Application) +getApplicationRepl = do + settings <- getAppSettings foundation <- getAppSettings >>= makeFoundation - wsettings <- getDevSettings $ warpSettings port foundation + wsettings <- getDevSettings $ warpSettings (appPort settings) foundation app1 <- makeApplication foundation return (getPort wsettings, foundation, app1) shutdownApp :: RegistryCtx -> IO () shutdownApp _ = return () +-- | For yesod devel, return the Warp settings and WAI Application. +getApplicationDev :: AppPort -> IO (Settings, Application) +getApplicationDev port = do + settings <- getAppSettings + foundation <- makeFoundation settings + app <- makeApplication foundation + wsettings <- getDevSettings $ warpSettings port foundation + return (wsettings, app) + +-- | main function for use by yesod devel +develMain :: IO () +develMain = do + settings <- getAppSettings + develMainHelper $ getApplicationDev $ appPort settings + --------------------------------------------- -- Functions for use in development with GHCi --------------------------------------------- diff --git a/src/Database/Marketplace.hs b/src/Database/Marketplace.hs new file mode 100644 index 0000000..b2484f9 --- /dev/null +++ b/src/Database/Marketplace.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DeriveGeneric #-} + +module Database.Marketplace where + +import Startlude hiding ((%), from, on) +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 => CategoryTitle -> Int64 -> Int64 -> Text -> ReaderT SqlBackend m [P.Entity SApp] +searchServices ANY pageItems offset' query = select $ do + service <- from $ table @SApp + where_ ((service ^. SAppDescShort `ilike` (%) ++. val query ++. (%)) + ||. (service ^. SAppDescLong `ilike` (%) ++. val query ++. (%)) + ||. (service ^. SAppTitle `ilike` (%) ++. val query ++. (%)) + ||. (service ^. SAppAppId `ilike` (%) ++. val query ++. (%))) + orderBy [ desc (service ^. SAppUpdatedAt) ] + limit pageItems + offset offset' + pure service +searchServices category pageItems offset' query = select $ do + services <- from + (do + (service :& sc) <- + from $ table @SApp + `innerJoin` table @ServiceCategory + `on` (\(s :& sc) -> + sc ^. ServiceCategoryServiceId ==. s ^. SAppId) + where_ $ sc ^. ServiceCategoryCategoryName ==. val category + &&. ((service ^. SAppDescShort `ilike` (%) ++. val query ++. (%)) + ||. (service ^. SAppDescLong `ilike` (%) ++. val query ++. (%)) + ||. (service ^. SAppTitle `ilike` (%) ++. val query ++. (%)) + ||. (service ^. SAppAppId `ilike` (%) ++. val query ++. (%)) + ) + pure service + ) + orderBy [ desc (services ^. SAppUpdatedAt) ] + limit pageItems + offset offset' + pure services + +newtype VersionsWithReleaseNotes = VersionsWithReleaseNotes (HashMap Version Text) deriving (Eq, Show, Generic) +instance FromJSON VersionsWithReleaseNotes +instance PersistField VersionsWithReleaseNotes where + fromPersistValue = fromPersistValueJSON + toPersistValue = PersistText . show + +-- 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] \ No newline at end of file diff --git a/src/Database/Queries.hs b/src/Database/Queries.hs index 3ab607d..8eeed7b 100644 --- a/src/Database/Queries.hs +++ b/src/Database/Queries.hs @@ -35,5 +35,5 @@ createAppVersion sId VersionInfo {..} = do createMetric :: MonadIO m => Key SApp -> Key SVersion -> ReaderT SqlBackend m () createMetric appId versionId = do - time <- liftIO $ getCurrentTime + time <- liftIO getCurrentTime insert_ $ Metric time appId versionId diff --git a/src/Foundation.hs b/src/Foundation.hs index 134c6ee..d3167c5 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -6,7 +6,7 @@ {-# LANGUAGE ViewPatterns #-} module Foundation where -import Startlude +import Startlude hiding (Handler) import Control.Monad.Logger ( LogSource ) import Database.Persist.Sql diff --git a/src/Handler/Apps.hs b/src/Handler/Apps.hs index c7261c5..7e85cb7 100644 --- a/src/Handler/Apps.hs +++ b/src/Handler/Apps.hs @@ -9,13 +9,12 @@ module Handler.Apps where -import Startlude +import Startlude hiding (Handler) import Control.Monad.Logger import Data.Aeson import qualified Data.Attoparsec.Text as Atto import qualified Data.ByteString.Lazy as BS -import Data.Char import Data.Conduit import qualified Data.Conduit.Binary as CB import qualified Data.HashMap.Strict as HM @@ -101,6 +100,7 @@ getAppsManifestR = do getSysR :: Extension "" -> Handler TypedContent getSysR e = do sysResourceDir <- ( "sys") . resourcesDir . appSettings <$> getYesod + -- @TODO update with new response type here getApp sysResourceDir e getAppManifestR :: AppIdentifier -> Handler TypedContent @@ -145,10 +145,10 @@ getApp rootDir ext@(Extension appId) = do case best of Nothing -> notFound Just (RegisteredAppVersion (appVersion, filePath)) -> do - exists <- liftIO $ doesFileExist filePath >>= \case + exists' <- liftIO $ doesFileExist filePath >>= \case True -> pure Existent False -> pure NonExistent - determineEvent exists (extension ext) filePath appVersion + determineEvent exists' (extension ext) filePath appVersion where determineEvent :: FileExistence -> String -> FilePath -> Version -> HandlerFor RegistryCtx TypedContent -- for app files diff --git a/src/Handler/Icons.hs b/src/Handler/Icons.hs index 13a9027..3c54854 100644 --- a/src/Handler/Icons.hs +++ b/src/Handler/Icons.hs @@ -4,7 +4,7 @@ module Handler.Icons where -import Startlude +import Startlude hiding (Handler) import Data.Conduit import qualified Data.Conduit.Binary as CB @@ -18,6 +18,7 @@ import System.FilePath (()) getIconsR :: Extension "png" -> Handler TypedContent getIconsR ext = do + -- @TODO switch to getting from service directory AppSettings{..} <- appSettings <$> getYesod mPng <- liftIO $ getUnversionedFileFromDir (resourcesDir "icons") ext case mPng of diff --git a/src/Handler/Marketplace.hs b/src/Handler/Marketplace.hs new file mode 100644 index 0000000..cee6d52 --- /dev/null +++ b/src/Handler/Marketplace.hs @@ -0,0 +1,319 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE QuasiQuotes #-} + + +module Handler.Marketplace where + +import Startlude hiding (from, Handler, on) +import Foundation +import Yesod.Core +import qualified Database.Persist as P +import Model +import Yesod.Persist.Core +import Database.Marketplace +import Data.List +import Lib.Types.Category +import Text.Read hiding (readMaybe) +import Lib.Types.AppIndex +import qualified Data.HashMap.Strict as HM +import Data.HashMap.Strict (HashMap) +import Lib.Types.Emver +import qualified Data.List.NonEmpty as NE +import Database.Esqueleto.Experimental +import Lib.Error +import Network.HTTP.Types +import Lib.Registry +import Settings +import System.FilePath.Posix +import Lib.External.AppMgr +import Data.Aeson +import qualified Data.ByteString.Lazy as BS +import qualified Data.Text as T +import Data.String.Interpolate.IsString + + +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 + toTypedContent = toTypedContent . toJSON +data ServiceRes = ServiceRes + { serviceResIcon :: Text + , serviceResManifest :: ServiceManifest + , serviceResCategories :: [CategoryTitle] + , serviceResVersions :: [Version] + , serviceResDependencyInfo :: HashMap AppIdentifier DependencyInfo + , serviceResReleaseNotes :: HashMap Version Text + } deriving (Show) +instance ToJSON ServiceRes where + toJSON ServiceRes {..} = object + [ "icon" .= serviceResIcon + , "manifest" .= serviceResManifest + , "categories" .= serviceResCategories + , "versions" .= serviceResVersions + , "dependency-metadata" .= serviceResDependencyInfo + , "release-notes" .= serviceResReleaseNotes + ] +instance ToContent ServiceRes where + toContent = toContent . toJSON +instance ToTypedContent ServiceRes where + toTypedContent = toTypedContent . toJSON +data DependencyInfo = DependencyInfo + { dependencyInfoTitle :: Text -- title + , dependencyInfoIcon :: Text -- url + } deriving (Eq, Show) +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 :: Text + , 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 + +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 + , serviceListCategory :: CategoryTitle + , serviceListQuery :: Text + } + deriving (Eq, Show, Read) + +getCategoriesR :: Handler CategoryRes +getCategoriesR = do + allCategories <- runDB $ select $ do from $ table @Category + pure $ CategoryRes $ categoryName . entityVal <$>allCategories + +getServiceListR :: Handler ServiceListRes +getServiceListR = do + getParameters <- reqGetParams <$> getRequest + let defaults = ServiceListDefaults { + serviceListOrder = DESC + , serviceListPageLimit = 20 + , serviceListPageNumber = 1 + , serviceListCategory = ANY + , serviceListQuery = "" + } + category <- case lookup "category" getParameters of + Nothing -> pure $ serviceListCategory defaults + Just c -> case readMaybe $ T.toUpper c of + Nothing -> do + $logInfo c + sendResponseStatus status400 ("could not read category" :: Text) + Just t -> pure t + page <- case lookup "page" getParameters of + Nothing -> pure $ serviceListPageNumber defaults + Just p -> case readMaybe p of + Nothing -> do + $logInfo p + sendResponseStatus status400 ("could not read page" :: Text) + Just t -> pure $ case t of + 0 -> 1 -- disallow page 0 so offset is not negative + _ -> t + limit' <- case lookup "per-page" getParameters of + Nothing -> pure $ serviceListPageLimit defaults + Just c -> case readMaybe $ toS c of + Nothing -> sendResponseStatus status400 ("could not read per-page" :: Text) + Just l -> pure l + query <- T.filter (not . isSpace) . fromMaybe (serviceListQuery defaults) <$> lookupGetParam "query" + $logInfo $ show category + filteredServices <- runDB $ searchServices category limit' ((page - 1) * limit') query + domain <- getsYesod $ registryHostname . appSettings + (appsDir, appMgrDir) <- getsYesod $ (( "apps") . resourcesDir &&& staticBinDir) . appSettings + services <- runDB $ traverse (mapEntityToServiceAvailable appMgrDir appsDir domain) filteredServices + pure $ ServiceListRes { + serviceListResCategories = [FEATURED .. MESSAGING] + , serviceListResServices = services + } + +getServiceR :: Handler ServiceRes +getServiceR = do + getParameters <- reqGetParams <$> getRequest + (service, version) <- case lookup "id" getParameters of + Nothing -> sendResponseStatus status404 ("id param should exist" :: Text) + Just appId' -> do + case lookup "version" getParameters of + Nothing -> do + -- default to latest - need to determine best available based on OS version? + runDB $ fetchLatestApp appId' >>= errOnNothing status404 "service not found" + Just c -> do + let version' = Version $ read $ toS c + runDB $ fetchLatestAppAtVersion appId' version' >>= errOnNothing status404 ("service at version " <> show version' <> " not found") + (versions, mappedVersions) <- fetchAllAppVersions (entityKey service) + categories <- runDB $ fetchAppCategories (entityKey service) + (appsDir, appMgrDir) <- getsYesod $ (( "apps") . resourcesDir &&& staticBinDir) . appSettings + let appId = sAppAppId $ entityVal service + let appVersion = sVersionNumber (entityVal version) + let appDir = (<> "/") . ( show version) . ( toS appId) $ appsDir + let appExt = Extension (toS appId) :: Extension "s9pk" + manifest' <- handleS9ErrT $ getManifest appMgrDir appDir appExt + manifest <- case eitherDecode $ BS.fromStrict manifest' of + Left e -> do + $logError "could not parse service manifest!" + $logError (show e) + sendResponseStatus status500 ("Internal Server Error" :: Text) + Right (a :: ServiceManifest) -> pure a + -- @TODO uncomment when new apps.yaml + -- let storeApp = fromMaybe + -- _ + -- (HM.lookup (sAppAppId $ entityVal service) + -- $ unAppManifest manifest) + -- let versionInfo = filter (\v -> versionInfoVersion v == appVersion) $ NE.toList $ storeAppVersionInfo storeApp + -- let deps = HM.toList (versionInfoDependencies $ Data.List.head versionInfo) + d <- traverse (mapDependencyMetadata appsDir appMgrDir) (HM.toList $ serviceManifestDependencies manifest) + icon <- decodeIcon appMgrDir appsDir appExt + pure $ ServiceRes + { serviceResIcon = icon + , serviceResManifest = manifest -- TypedContent "application/json" (toContent manifest) + , serviceResCategories = serviceCategoryCategoryName . entityVal <$> categories + , serviceResVersions = versionInfoVersion <$> versions + , serviceResDependencyInfo = HM.fromList d + , serviceResReleaseNotes = mappedVersions + } + +type URL = Text +mapDependencyMetadata :: (MonadIO m, MonadHandler m) => FilePath -> FilePath -> (AppIdentifier, ServiceDependencyInfo) -> m (AppIdentifier, DependencyInfo) +mapDependencyMetadata appsDir appmgrPath (appId, depInfo) = do + let ext = (Extension (toS appId) :: Extension "s9pk") + -- use if we have VersionRange instead of Version + -- version <- getBestVersion appsDir ext (snd dep) >>= \case + -- Nothing -> sendResponseStatus status400 ("Specified App Version Not Found" :: Text) + -- Just v -> pure v + let depPath = appsDir toS appId show (serviceDependencyInfoVersion depInfo) + icon <- decodeIcon appmgrPath depPath ext + pure (appId, DependencyInfo + { dependencyInfoTitle = appId + , dependencyInfoIcon = icon + }) + +decodeIcon :: (MonadHandler m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> m URL +decodeIcon appmgrPath depPath e@(Extension icon) = do + icon' <- handleS9ErrT $ getIcon appmgrPath depPath e + case eitherDecode $ BS.fromStrict icon' of + Left e' -> do + $logInfo $ T.pack e' + sendResponseStatus status400 e' + Right (i' :: URL) -> pure $ i' <> T.pack icon + +fetchAllAppVersions :: Key SApp -> HandlerFor RegistryCtx ([VersionInfo], HashMap Version Text) +fetchAllAppVersions appId = do + entityAppVersions <- runDB $ P.selectList [SVersionAppId P.==. appId] [] -- orderby version + let vers = entityVal <$> entityAppVersions + let vv = mapSVersionToVersionInfo vers + let mappedVersions = HM.fromList $ (\v -> (versionInfoVersion v, versionInfoReleaseNotes v)) <$> vv + pure (vv, mappedVersions) + +fetchMostRecentAppVersions :: MonadIO m => Key SApp -> ReaderT SqlBackend m [Entity SVersion] +fetchMostRecentAppVersions appId = select $ do + version <- from $ table @SVersion + where_ (version ^. SVersionAppId ==. val appId) + orderBy [ asc (version ^. SVersionNumber) ] + limit 1 + pure version + +fetchLatestApp :: MonadIO m => Text -> ReaderT SqlBackend m (Maybe (P.Entity SApp, P.Entity SVersion)) +fetchLatestApp appId = selectOne $ do + (service :& version) <- + from $ table @SApp + `innerJoin` table @SVersion + `on` (\(service :& version) -> + service ^. SAppId ==. version ^. SVersionAppId) + where_ (service ^. SAppAppId ==. val appId) + orderBy [ desc (version ^. SVersionNumber)] + pure (service, version) + +fetchLatestAppAtVersion :: MonadIO m => Text -> 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) + +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 + +mapEntityToStoreApp :: MonadIO m => Entity SApp -> ReaderT SqlBackend m StoreApp +mapEntityToStoreApp serviceEntity = do + let service = entityVal serviceEntity + entityVersion <- fetchMostRecentAppVersions $ entityKey serviceEntity + let vers = entityVal <$> entityVersion + let vv = mapSVersionToVersionInfo vers + pure $ StoreApp { + storeAppTitle = sAppTitle service + , storeAppDescShort = sAppDescShort service + , storeAppDescLong = sAppDescLong service + , storeAppVersionInfo = NE.fromList vv + , storeAppIconType = sAppIconType service + , storeAppTimestamp = Just (sAppCreatedAt service) -- case on if updatedAt? or always use updated time? was file timestamp + } + +mapEntityToServiceAvailable :: (MonadIO m, MonadHandler m) => FilePath -> FilePath -> Text -> Entity SApp -> ReaderT SqlBackend m ServiceAvailable +mapEntityToServiceAvailable appMgrDir appsDir domain service = do + -- @TODO uncomment and replace icon when portable embassy-sdk live + -- icon <- decodeIcon appMgrDir appsDir (Extension "png") + let appId = sAppAppId $ entityVal service + let icon = [i|https://#{domain}/icons/#{appId}.png|] + (_, v) <- fetchLatestApp appId >>= errOnNothing status404 "service not found" + let appVersion = sVersionNumber (entityVal v) + pure $ ServiceAvailable + { serviceAvailableId = appId + , serviceAvailableTitle = sAppTitle $ entityVal service + , serviceAvailableDescShort = sAppDescShort $ entityVal service + , serviceAvailableVersion = appVersion + , serviceAvailableIcon = icon + } \ No newline at end of file diff --git a/src/Handler/Types/Status.hs b/src/Handler/Types/Status.hs index 24a8c63..5afdc1a 100644 --- a/src/Handler/Types/Status.hs +++ b/src/Handler/Types/Status.hs @@ -3,7 +3,7 @@ {-# LANGUAGE NamedFieldPuns #-} module Handler.Types.Status where -import Startlude +import Startlude hiding (toLower) import Data.Aeson import Yesod.Core.Content diff --git a/src/Handler/Version.hs b/src/Handler/Version.hs index c71ff76..42d51c6 100644 --- a/src/Handler/Version.hs +++ b/src/Handler/Version.hs @@ -6,7 +6,7 @@ module Handler.Version where -import Startlude +import Startlude hiding (Handler) import Control.Monad.Trans.Maybe import Yesod.Core @@ -48,4 +48,4 @@ getVersionWSpec rootDir ext = do getSystemStatusR :: Handler OSVersionRes getSystemStatusR = do -- hardcoded to the next major version release so the UI can by dynamic. this might change depending on the version number we decide to release. - pure $ OSVersionRes NOTHING $ Version (1,0,0,0) \ No newline at end of file + pure $ OSVersionRes NOTHING $ Version (0,3,0,0) \ No newline at end of file diff --git a/src/Lib/External/AppMgr.hs b/src/Lib/External/AppMgr.hs index e3b4a43..efe589b 100644 --- a/src/Lib/External/AppMgr.hs +++ b/src/Lib/External/AppMgr.hs @@ -25,11 +25,11 @@ readProcessWithExitCode' a b c = liftIO $ do $ setStderr byteStringOutput $ setEnvInherit $ setStdout byteStringOutput - $ (System.Process.Typed.proc a b) + $ System.Process.Typed.proc a b withProcessWait pc $ \process -> atomically $ liftA3 (,,) (waitExitCodeSTM process) - (fmap LBS.toStrict $ getStdout process) - (fmap LBS.toStrict $ getStderr process) + (LBS.toStrict <$> getStdout process) + (LBS.toStrict <$> getStderr process) readProcessInheritStderr :: MonadIO m => String -> [String] -> ByteString -> m (ExitCode, ByteString) readProcessInheritStderr a b c = liftIO $ do @@ -38,20 +38,27 @@ readProcessInheritStderr a b c = liftIO $ do $ setStderr inherit $ setEnvInherit $ setStdout byteStringOutput - $ (System.Process.Typed.proc a b) + $ System.Process.Typed.proc a b withProcessWait pc - $ \process -> atomically $ liftA2 (,) (waitExitCodeSTM process) (fmap LBS.toStrict $ getStdout process) + $ \process -> atomically $ liftA2 (,) (waitExitCodeSTM process) (LBS.toStrict <$> getStdout process) getConfig :: (MonadIO m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> S9ErrT m Text getConfig appmgrPath appPath e@(Extension appId) = fmap decodeUtf8 $ do - (ec, out) <- readProcessInheritStderr (appmgrPath <> "appmgr") ["inspect", "info", appPath <> (show e), "-C", "--json"] "" + (ec, out) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "config", appPath <> show e, "--json"] "" case ec of ExitSuccess -> pure out - ExitFailure n -> throwE $ AppMgrE [i|info #{appId} -C \--json|] n + ExitFailure n -> throwE $ AppMgrE [i|info config #{appId} \--json|] n getManifest :: (MonadIO m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> S9ErrT m ByteString getManifest appmgrPath appPath e@(Extension appId) = do - (ec, bs) <- readProcessInheritStderr (appmgrPath <> "appmgr") ["inspect", "info", appPath <> (show e), "-M", "--json"] "" + (ec, bs) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "manifest", appPath <> show e, "--json"] "" case ec of ExitSuccess -> pure bs - ExitFailure n -> throwE $ AppMgrE [i|info -M #{appId} \--json|] n \ No newline at end of file + ExitFailure n -> throwE $ AppMgrE [i|info manifest #{appId} \--json|] n + +getIcon :: (MonadIO m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> S9ErrT m ByteString +getIcon appmgrPath appPath e@(Extension icon) = do + (ec, bs) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "icon", appPath <> show e] "" + case ec of + ExitSuccess -> pure bs + ExitFailure n -> throwE $ AppMgrE [i|icon #{icon} \--json|] n \ No newline at end of file diff --git a/src/Lib/Registry.hs b/src/Lib/Registry.hs index d586245..cb993d4 100644 --- a/src/Lib/Registry.hs +++ b/src/Lib/Registry.hs @@ -27,6 +27,7 @@ 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) @@ -58,6 +59,7 @@ 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 @@ -72,7 +74,7 @@ instance KnownSymbol a => Show (Extension a) where show e@(Extension file) = file <.> extension e instance KnownSymbol a => Read (Extension a) where - readsPrec _ s = case (symbolVal $ Proxy @a) of + readsPrec _ s = case symbolVal $ Proxy @a of "" -> [(Extension s, "")] other -> [ (Extension file, "") | ext' == "" <.> other ] where (file, ext') = splitExtension s diff --git a/src/Lib/SystemCtl.hs b/src/Lib/SystemCtl.hs index f79e02e..0800f00 100644 --- a/src/Lib/SystemCtl.hs +++ b/src/Lib/SystemCtl.hs @@ -1,9 +1,8 @@ module Lib.SystemCtl where import Startlude hiding (words) -import Unsafe +import Protolude.Unsafe -import Data.Char import Data.String import System.Process import Text.Casing diff --git a/src/Lib/Types/AppIndex.hs b/src/Lib/Types/AppIndex.hs index e939e6d..4092031 100644 --- a/src/Lib/Types/AppIndex.hs +++ b/src/Lib/Types/AppIndex.hs @@ -1,6 +1,8 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} module Lib.Types.AppIndex where import Startlude hiding ( Any ) @@ -14,19 +16,32 @@ import Lib.Types.Emver import Orphans.Emver ( ) import System.Directory import Lib.Registry +import Model +import qualified Data.Text as T type AppIdentifier = Text data VersionInfo = VersionInfo { versionInfoVersion :: Version , versionInfoReleaseNotes :: Text - , versionInfoDependencies :: HM.HashMap Text VersionRange + , versionInfoDependencies :: HM.HashMap AppIdentifier VersionRange , versionInfoOsRequired :: VersionRange , versionInfoOsRecommended :: VersionRange , versionInfoInstallAlert :: Maybe Text } deriving (Eq, Show) +mapSVersionToVersionInfo :: [SVersion] -> [VersionInfo] +mapSVersionToVersionInfo sv = do + (\v -> VersionInfo { + versionInfoVersion = sVersionNumber v + , versionInfoReleaseNotes = sVersionReleaseNotes v + , versionInfoDependencies = HM.empty + , versionInfoOsRequired = sVersionOsVersionRequired v + , versionInfoOsRecommended = sVersionOsVersionRecommended v + , versionInfoInstallAlert = Nothing + }) <$> sv + instance Ord VersionInfo where compare = compare `on` versionInfoVersion @@ -68,7 +83,6 @@ instance ToJSON StoreApp where , "version-info" .= storeAppVersionInfo , "timestamp" .= storeAppTimestamp ] - newtype AppManifest = AppManifest { unAppManifest :: HM.HashMap AppIdentifier StoreApp} deriving (Show) @@ -90,7 +104,6 @@ instance FromJSON AppManifest where instance ToJSON AppManifest where toJSON = toJSON . unAppManifest - filterOsRequired :: Version -> StoreApp -> Maybe StoreApp filterOsRequired av sa = case NE.filter ((av <||) . versionInfoOsRequired) (storeAppVersionInfo sa) of [] -> Nothing @@ -107,4 +120,71 @@ addFileTimestamp appDir ext service v = do Nothing -> pure Nothing Just file -> do time <- getModificationTime file - pure $ Just service {storeAppTimestamp = Just time } \ No newline at end of file + pure $ Just service {storeAppTimestamp = Just time } + +data ServiceDependencyInfo = ServiceDependencyInfo + { serviceDependencyInfoOptional :: Maybe Text + , serviceDependencyInfoRecommended :: Bool + , serviceDependencyInfoVersion :: Version + , serviceDependencyInfoDescription :: Maybe Text + } deriving (Show) +instance FromJSON ServiceDependencyInfo where + parseJSON = withObject "service dependency info" $ \o -> do + serviceDependencyInfoOptional <- o .:? "optional" + serviceDependencyInfoRecommended <- o .: "recommended" + serviceDependencyInfoVersion <- o .: "version" + serviceDependencyInfoDescription <- o .:? "description" + pure ServiceDependencyInfo { .. } + +instance ToJSON ServiceDependencyInfo where + toJSON ServiceDependencyInfo {..} = object + [ "description" .= serviceDependencyInfoDescription + , "version" .= serviceDependencyInfoVersion + , "recommended" .= serviceDependencyInfoRecommended + , "optional" .= serviceDependencyInfoOptional + ] +data ServiceAlert = INSTALL | UNINSTALL | RESTORE | START | STOP + deriving (Show, Eq, Generic, Hashable) +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 :: AppIdentifier + , serviceManifestTitle :: Text + , serviceManifestVersion :: Version + , serviceManifestDescriptionLong :: Text + , serviceManifestDescriptionShort :: Text + , serviceManifestReleaseNotes :: Text + , serviceManifestAlerts :: HM.HashMap ServiceAlert (Maybe Text) + , serviceManifestDependencies :: HM.HashMap AppIdentifier ServiceDependencyInfo + } deriving (Show) +instance FromJSON ServiceManifest where + parseJSON = withObject "service manifest" $ \o -> do + serviceManifestId <- o .: "id" + serviceManifestTitle <- o .: "title" + serviceManifestVersion <- o .: "version" + serviceManifestDescriptionLong <- o .: "description" >>= (.: "long") + serviceManifestDescriptionShort <- o .: "description" >>= (.: "short") + serviceManifestReleaseNotes <- o .: "release-notes" + serviceManifestAlerts <- o .: "alerts" + 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" .= serviceManifestAlerts + , "dependencies" .= serviceManifestDependencies + ] \ No newline at end of file diff --git a/src/Lib/Types/Category.hs b/src/Lib/Types/Category.hs new file mode 100644 index 0000000..df0e080 --- /dev/null +++ b/src/Lib/Types/Category.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} + + +module Lib.Types.Category where + +import Startlude +import Database.Persist.Postgresql +import Data.Aeson +import qualified Data.Text as T +import Control.Monad +import Yesod.Core +import Data.String.Interpolate.IsString +import qualified Data.ByteString.Lazy as BS + +data CategoryTitle = FEATURED + | BITCOIN + | LIGHTNING + | DATA + | MESSAGING + | NONE + | ANY + deriving (Eq, Show, Enum, Read) +instance PersistField CategoryTitle where + fromPersistValue = fromPersistValueJSON + toPersistValue = toPersistValueJSON +instance PersistFieldSql CategoryTitle where + sqlType _ = SqlString +instance ToJSON CategoryTitle where + toJSON = String . show +instance FromJSON CategoryTitle where + parseJSON = withText "CategoryTitle" $ \case + "FEATURED" -> pure FEATURED + "BITCOIN" -> pure BITCOIN + "LIGHTNING" -> pure LIGHTNING + "DATA" -> pure DATA + "MESSAGING" -> pure MESSAGING + "NONE" -> pure NONE + "ANY" -> pure ANY + _ -> fail "unknown category title" +instance ToContent CategoryTitle where + toContent = toContent . toJSON +instance ToTypedContent CategoryTitle where + toTypedContent = toTypedContent . toJSON + +cat :: BS.ByteString +cat = [i|"featured"|] + diff --git a/src/Lib/Types/Emver.hs b/src/Lib/Types/Emver.hs index 79d8e81..55843db 100644 --- a/src/Lib/Types/Emver.hs +++ b/src/Lib/Types/Emver.hs @@ -48,9 +48,11 @@ import Control.Applicative ( liftA2 ) import Data.String ( IsString(..) ) import qualified Data.Text as T +import Data.Aeson +import Startlude (Hashable) -- | AppVersion is the core representation of the SemverQuad type. -newtype Version = Version { unVersion :: (Word, Word, Word, Word) } deriving (Eq, Ord) +newtype Version = Version { unVersion :: (Word, Word, Word, Word) } deriving (Eq, Ord, ToJSONKey, Hashable) instance Show Version where show (Version (x, y, z, q)) = let postfix = if q == 0 then "" else '.' : show q in show x <> "." <> show y <> "." <> show z <> postfix diff --git a/src/Model.hs b/src/Model.hs index 5db7adc..153cef5 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -13,9 +13,9 @@ module Model where import Startlude import Database.Persist.TH import Lib.Types.Emver +import Lib.Types.Category import Orphans.Emver ( ) - share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| SApp createdAt UTCTime @@ -41,6 +41,14 @@ SVersion sql=version deriving Eq deriving Show +OsVersion + createdAt UTCTime + updatedAt UTCTime + number Version + headline Text + releaseNotes Text + deriving Eq + deriving Show Metric createdAt UTCTime @@ -48,4 +56,22 @@ Metric version SVersionId deriving Eq deriving Show + +Category + createdAt UTCTime + name CategoryTitle + parent CategoryId Maybe + description Text + deriving Eq + deriving Show + +ServiceCategory + createdAt UTCTime + serviceId SAppId + categoryId CategoryId + serviceName Text -- SAppAppId + categoryName CategoryTitle -- CategoryTitle + priority Int Maybe + deriving Eq + deriving Show |] diff --git a/src/Util/Shared.hs b/src/Util/Shared.hs index c183e1e..50eaaee 100644 --- a/src/Util/Shared.hs +++ b/src/Util/Shared.hs @@ -1,8 +1,7 @@ module Util.Shared where -import Startlude +import Startlude hiding (Handler) -import Data.Char import qualified Data.Text as T import Network.HTTP.Types import Yesod.Core @@ -18,7 +17,11 @@ getVersionFromQuery rootDir ext = do spec <- case readMaybe specString of Nothing -> sendResponseStatus status400 ("Invalid App Version Specification" :: Text) Just t -> pure t + getBestVersion rootDir ext spec + +getBestVersion :: (MonadIO m, KnownSymbol a, MonadLogger m) => FilePath -> Extension a -> VersionRange -> m (Maybe Version) +getBestVersion rootDir ext spec = do appVersions <- liftIO $ getAvailableAppVersions rootDir ext let satisfactory = filter ((<|| spec) . fst . unRegisteredAppVersion) appVersions let best = getMax <$> foldMap (Just . Max . fst . unRegisteredAppVersion) satisfactory - pure best + pure best \ No newline at end of file diff --git a/stack.yaml b/stack.yaml index 5af9d27..940057b 100644 --- a/stack.yaml +++ b/stack.yaml @@ -29,7 +29,7 @@ resolver: lts-18.11 # - auto-update # - wai packages: -- . + - . # Dependency packages to be pulled from upstream that are not in the resolver. # These entries can reference officially published versions as well as # forks / in-progress versions pinned to a git hash. For example: @@ -40,8 +40,8 @@ packages: # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a # extra-deps: - - protolude-0.2.4 - + - protolude-0.3.0 + - esqueleto-3.5.1.0 # Override default flag values for local packages and extra-deps # flags: {} @@ -66,4 +66,4 @@ extra-deps: # Allow a newer minor version of GHC than the snapshot specifies # compiler-check: newer-minor # docker: - # enable: true +# enable: true diff --git a/test/Handler/AppSpec.hs b/test/Handler/AppSpec.hs index af80566..e2b7fa2 100644 --- a/test/Handler/AppSpec.hs +++ b/test/Handler/AppSpec.hs @@ -35,7 +35,7 @@ spec = do withApp $ it "creates app and metric records" $ do request $ do setMethod "GET" - setUrl ("/apps/bitcoind.s9pk?spec=0.18.1" :: Text) + setUrl ("/apps/bitcoind.s9pk?spec==0.18.1" :: Text) statusIs 200 apps <- runDBtest $ selectList [SAppAppId ==. "bitcoind"] [] assertEq "app should exist" (length apps) 1 @@ -53,7 +53,7 @@ spec = do let app = fromJust $ head apps metrics <- runDBtest $ selectList [MetricAppId ==. entityKey app] [] assertEq "metric should exist" (length metrics) 1 - version <- runDBtest $ selectList [VersionAppId ==. entityKey app] [] + version <- runDBtest $ selectList [SVersionAppId ==. entityKey app] [] assertEq "version should exist" (length version) 1 describe "GET /sys/proxy.pac" $ withApp $ it "does not record metric but request successful" $ do @@ -72,10 +72,11 @@ spec = do statusIs 200 apps <- runDBtest $ selectList ([] :: [Filter SApp])[] assertEq "no apps should exist" (length apps) 0 - describe "GET /apps/#S9PK/#Text/manifest" $ + -- @TODO uncomment when new portable appmgr live + xdescribe "GET /apps/manifest/#S9PK" $ withApp $ it "gets bitcoin manifest" $ do request $ do setMethod "GET" - setUrl ("/apps/bitcoind.s9pk/0.2.5/manifest" :: Text) + setUrl ("/apps/manifest/bitcoind?spec==0.20.1" :: Text) statusIs 200 bodyContains "{\"id\":\"bitcoind\",\"version\":\"0.20.1\",\"title\":\"Bitcoin Core\",\"description\":{\"short\":\"Bitcoin Full Node by Bitcoin Core\",\"long\":\"Bitcoin is an innovative payment network and a new kind of money. Bitcoin uses peer-to-peer technology to operate with no central authority or banks; managing transactions and the issuing of bitcoins is carried out collectively by the network. Bitcoin is open-source; its design is public, nobody owns or controls Bitcoin and everyone can take part. Through many of its unique properties, Bitcoin allows exciting uses that could not be covered by any previous payment system.\"},\"release-notes\":\"https://github.com/bitcoin/bitcoin/blob/master/doc/release-notes/release-notes-0.20.1.md\",\"has-instructions\":true,\"os-version-required\":\">=0.2.4\",\"os-version-recommended\":\">=0.2.4\",\"ports\":[{\"internal\":8332,\"tor\":8332},{\"internal\":8333,\"tor\":8333}],\"image\":{\"type\":\"tar\"},\"mount\":\"/root/.bitcoin\",\"assets\":[{\"src\":\"bitcoin.conf.template\",\"dst\":\".\",\"overwrite\":true}],\"hidden-service-version\":\"v2\",\"dependencies\":{}}" diff --git a/test/Handler/MarketplaceSpec.hs b/test/Handler/MarketplaceSpec.hs new file mode 100644 index 0000000..c4a790b --- /dev/null +++ b/test/Handler/MarketplaceSpec.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE TypeFamilies #-} + +module Handler.MarketplaceSpec (spec) where + +import Startlude hiding (Any) +import Database.Persist.Sql +import Data.Maybe + +import TestImport +import Model +import Database.Marketplace +import Lib.Types.Category +import Lib.Types.Emver + +spec :: Spec +spec = do + describe "searchServices with category" $ + withApp $ it "should filter services with featured category" $ do + time <- liftIO getCurrentTime + btc <- runDBtest $ insert $ SApp time (Just time) "Bitcoin Core" "bitcoind" "short desc bitcoin" "long desc bitcoin" "png" + lnd <- runDBtest $ insert $ SApp time (Just time) "Lightning Network Daemon" "lnd" "short desc lnd" "long desc lnd" "png" + featuredCat <- runDBtest $ insert $ Category time FEATURED Nothing "desc" + btcCat <- runDBtest $ insert $ Category time BITCOIN Nothing "desc" + lnCat <- runDBtest $ insert $ Category time LIGHTNING Nothing "desc" + _ <- runDBtest $ insert_ $ ServiceCategory time btc featuredCat "bitcoin" FEATURED Nothing + _ <- 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 FEATURED 20 0 "" + assertEq "should exist" (length apps) 1 + let app' = fromJust $ head apps + assertEq "should be bitcoin" (sAppTitle $ entityVal app') "Bitcoin Core" + describe "searchServices with category" $ + withApp $ it "should filter services with bitcoin category" $ do + time <- liftIO getCurrentTime + btc <- runDBtest $ insert $ SApp time (Just time) "Bitcoin Core" "bitcoind" "short desc bitcoin" "long desc bitcoin" "png" + lnd <- runDBtest $ insert $ SApp time (Just time) "Lightning Network Daemon" "lnd" "short desc lnd" "long desc lnd" "png" + featuredCat <- runDBtest $ insert $ Category time FEATURED Nothing "desc" + btcCat <- runDBtest $ insert $ Category time BITCOIN Nothing "desc" + lnCat <- runDBtest $ insert $ Category time LIGHTNING Nothing "desc" + _ <- runDBtest $ insert_ $ ServiceCategory time btc featuredCat "bitcoin" FEATURED Nothing + _ <- 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 BITCOIN 20 0 "" + assertEq "should exist" (length apps) 2 + describe "searchServices with fuzzy query" $ + withApp $ it "runs search service with fuzzy text in long description" $ do + time <- liftIO getCurrentTime + app1 <- runDBtest $ insert $ SApp time (Just time) "Bitcoin Core" "bitcoind" "short desc" "long desc" "png" + app2 <- runDBtest $ insert $ SApp time (Just time) "Lightning Network Daemon" "lnd" "short desc" "lightning long desc" "png" + cate <- runDBtest $ insert $ Category time FEATURED Nothing "desc" + _ <- runDBtest $ insert_ $ ServiceCategory time app1 cate "bitcoind" FEATURED Nothing + _ <- runDBtest $ insert_ $ ServiceCategory time app2 cate "lnd" FEATURED Nothing + apps <- runDBtest $ searchServices FEATURED 20 0 "lightning" + assertEq "should exist" (length apps) 1 + let app' = fromJust $ head apps + print app' + describe "searchServices with any category" $ + withApp $ it "runs search service for any category" $ do + time <- liftIO getCurrentTime + btc <- runDBtest $ insert $ SApp time (Just time) "Bitcoin Core" "bitcoind" "short desc bitcoin" "long desc bitcoin" "png" + _ <- runDBtest $ insert $ SVersion time (Just time)btc "0.19.0" "notes" Any Any + _ <- runDBtest $ insert $ SVersion time (Just time)btc "0.20.0" "notes" Any Any + lnd <- runDBtest $ insert $ SApp time (Just time) "Lightning Network Daemon" "lnd" "short desc lnd" "long desc lnd" "png" + _ <- runDBtest $ insert $ SVersion time (Just time)lnd "0.18.0" "notes" Any Any + _ <- runDBtest $ insert $ SVersion time (Just time)lnd "0.17.0" "notes" Any Any + featuredCat <- runDBtest $ insert $ Category time FEATURED Nothing "desc" + btcCat <- runDBtest $ insert $ Category time BITCOIN Nothing "desc" + lnCat <- runDBtest $ insert $ Category time LIGHTNING Nothing "desc" + _ <- runDBtest $ insert_ $ ServiceCategory time btc featuredCat "bitcoin" FEATURED Nothing + _ <- 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 ANY 20 0 "" + assertEq "should exist" (length apps) 2 + -- describe "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" "*" "*" + -- _ <- runDBtest $ insert $ SVersion time Nothing app "0.20.0.0" "release notes 0.19.0.0" "*" "*" + -- res <- runDBtest $ getServiceVersionsWithReleaseNotes "bitcoin" + -- print res \ No newline at end of file diff --git a/test/TestImport.hs b/test/TestImport.hs index 15e243a..92652ef 100644 --- a/test/TestImport.hs +++ b/test/TestImport.hs @@ -8,7 +8,7 @@ module TestImport ) where -import Startlude +import Startlude hiding (Handler) import Application ( makeFoundation , makeLogWare ) @@ -23,6 +23,8 @@ import Database.Persist.Sql import Text.Shakespeare.Text ( st ) import Yesod.Core import qualified Data.Text as T +import Database.Esqueleto.Internal.Internal +import Database.Persist.Sql.Types.Internal runHandler :: Handler a -> YesodExample RegistryCtx a runHandler handler = do @@ -55,8 +57,8 @@ wipeDB app = runDBWithApp app $ do tables <- getTables sqlBackend <- ask - let escapedTables = map (T.unpack . connEscapeName sqlBackend . DBName) tables - query = "TRUNCATE TABLE " ++ (intercalate ", " escapedTables) + let escapedTables = map (T.unpack . connEscapeRawName sqlBackend . unDBName . DBName) tables + query = "TRUNCATE TABLE " ++ intercalate ", " escapedTables rawExecute (T.pack query) [] runDBtest :: SqlPersistM a -> YesodExample RegistryCtx a