Start9/registry
2
0
Fork 0
mirror of https://github.com/Start9Labs/registry.git synced 2026-03-26 02:11:53 +00:00
Code Issues Packages Projects Releases Wiki Activity

categories refactor

Browse Source
This commit is contained in:
Lucy Cifferello
2021-06-30 09:36:49 -04:00
committed by Keagan McClelland
parent e81b3b7546
commit 64fc16813f
27 changed files with 817 additions and 50 deletions
Download Patch File Download Diff File Expand all files Collapse all files

3
.gitignore vendored
View File

@@ -28,4 +28,5 @@ agent_*
agent.*
version
**/*.s9pk
**/appmgr
**/appmgr
0.3.0_features.md

106
app/DevelMain.hs Normal file
View File

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

6
app/devel.hs Normal file
View File

@@ -0,0 +1,6 @@
{-# LANGUAGE PackageImports #-}
import "start9-registry" Application (develMain)
import Prelude (IO)
main :: IO ()
main = develMain

5
config/routes
View File

@@ -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}
!/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

4
config/settings.yml
View File

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

3
package.yaml
View File

@@ -53,6 +53,9 @@ dependencies:
- yesod
- yesod-core
- yesod-persistent
- esqueleto
- text-conversions
- foreign-store
library:
source-dirs: src

26
src/Application.hs
View File

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

56
src/Database/Marketplace.hs Normal file
View File

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

2
src/Database/Queries.hs
View File

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

2
src/Foundation.hs
View File

@@ -6,7 +6,7 @@
{-# LANGUAGE ViewPatterns #-}
module Foundation where
import Startlude
import Startlude hiding (Handler)
import Control.Monad.Logger ( LogSource )
import Database.Persist.Sql

8
src/Handler/Apps.hs
View File

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

3
src/Handler/Icons.hs
View File

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

319
src/Handler/Marketplace.hs Normal file
View File

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

2
src/Handler/Types/Status.hs
View File

@@ -3,7 +3,7 @@
{-# LANGUAGE NamedFieldPuns #-}
module Handler.Types.Status where
import Startlude
import Startlude hiding (toLower)
import Data.Aeson
import Yesod.Core.Content

4
src/Handler/Version.hs
View File

@@ -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)
pure $ OSVersionRes NOTHING $ Version (0,3,0,0)

25
src/Lib/External/AppMgr.hs vendored
View File

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

4
src/Lib/Registry.hs
View File

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

3
src/Lib/SystemCtl.hs
View File

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

88
src/Lib/Types/AppIndex.hs
View File

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

48
src/Lib/Types/Category.hs Normal file
View File

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

4
src/Lib/Types/Emver.hs
View File

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

28
src/Model.hs
View File

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

9
src/Util/Shared.hs
View File

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

8
stack.yaml
View File

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

9
test/Handler/AppSpec.hs
View File

@@ -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\":{}}"

84
test/Handler/MarketplaceSpec.hs Normal file
View File

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

8
test/TestImport.hs
View File

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