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

format all the things

Browse Source
This commit is contained in:
Lucy Cifferello
2021-09-23 19:18:25 -06:00
committed by Keagan McClelland
parent ac5acaa685
commit e2d2fb6afc
24 changed files with 604 additions and 515 deletions
Download Patch File Download Diff File Expand all files Collapse all files

79
app/DevelMain.hs
View File

@@ -1,14 +1,16 @@
module DevelMain where module DevelMain where
import Prelude import Prelude
import Application (getApplicationRepl, shutdownApp) import Application ( getApplicationRepl
, shutdownApp
)
import Control.Monad ((>=>)) import Control.Monad ( (>=>) )
import Control.Concurrent import Control.Concurrent
import Data.IORef import Data.IORef
import Foreign.Store import Foreign.Store
import Network.Wai.Handler.Warp import Network.Wai.Handler.Warp
import GHC.Word import GHC.Word
-- | Running your app inside GHCi. -- | Running your app inside GHCi.
@@ -55,36 +57,35 @@ update = do
mtidStore <- lookupStore tidStoreNum mtidStore <- lookupStore tidStoreNum
case mtidStore of case mtidStore of
-- no server running -- no server running
Nothing -> do Nothing -> do
done <- storeAction doneStore newEmptyMVar done <- storeAction doneStore newEmptyMVar
tid <- start done tid <- start done
_ <- storeAction (Store tidStoreNum) (newIORef tid) _ <- storeAction (Store tidStoreNum) (newIORef tid)
return () return ()
-- server is already running -- server is already running
Just tidStore -> restartAppInNewThread tidStore Just tidStore -> restartAppInNewThread tidStore
where where
doneStore :: Store (MVar ()) doneStore :: Store (MVar ())
doneStore = Store 0 doneStore = Store 0
-- shut the server down with killThread and wait for the done signal -- shut the server down with killThread and wait for the done signal
restartAppInNewThread :: Store (IORef ThreadId) -> IO () restartAppInNewThread :: Store (IORef ThreadId) -> IO ()
restartAppInNewThread tidStore = modifyStoredIORef tidStore $ \tid -> do restartAppInNewThread tidStore = modifyStoredIORef tidStore $ \tid -> do
killThread tid killThread tid
withStore doneStore takeMVar withStore doneStore takeMVar
readStore doneStore >>= start readStore doneStore >>= start
-- | Start the server in a separate thread. -- | Start the server in a separate thread.
start :: MVar () -- ^ Written to when the thread is killed. start :: MVar () -- ^ Written to when the thread is killed.
-> IO ThreadId -> IO ThreadId
start done = do start done = do
(port, site, app) <- getApplicationRepl (port, site, app) <- getApplicationRepl
forkFinally forkFinally (runSettings (setPort port defaultSettings) app)
(runSettings (setPort port defaultSettings) app) -- Note that this implies concurrency
-- Note that this implies concurrency -- between shutdownApp and the next app that is starting.
-- between shutdownApp and the next app that is starting. -- Normally this should be fine
-- Normally this should be fine (\_ -> putMVar done () >> shutdownApp site)
(\_ -> putMVar done () >> shutdownApp site)
-- | kill the server -- | kill the server
shutdown :: IO () shutdown :: IO ()
@@ -92,10 +93,10 @@ shutdown = do
mtidStore <- lookupStore tidStoreNum mtidStore <- lookupStore tidStoreNum
case mtidStore of case mtidStore of
-- no server running -- no server running
Nothing -> putStrLn "no Yesod app running" Nothing -> putStrLn "no Yesod app running"
Just tidStore -> do Just tidStore -> do
withStore tidStore $ readIORef >=> killThread withStore tidStore $ readIORef >=> killThread
putStrLn "Yesod app is shutdown" putStrLn "Yesod app is shutdown"
tidStoreNum :: Word32 tidStoreNum :: Word32
tidStoreNum = 1 tidStoreNum = 1

4
app/devel.hs
View File

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

2
app/main.hs
View File

@@ -1,4 +1,4 @@
import Application (appMain) import Application ( appMain )
import Startlude import Startlude
main :: IO () main :: IO ()

58
src/Database/Marketplace.hs
View File

@@ -4,45 +4,53 @@
module Database.Marketplace where module Database.Marketplace where
import Startlude hiding ((%), from, on) import Startlude hiding ( (%)
import Database.Esqueleto.Experimental , from
import Lib.Types.Category , on
import Model )
import qualified Database.Persist as P import Database.Esqueleto.Experimental
import Data.HashMap.Strict import Lib.Types.Category
import Data.Version import Model
import Data.Aeson import qualified Database.Persist as P
import Data.HashMap.Strict
import Data.Version
import Data.Aeson
searchServices :: MonadIO m => Maybe CategoryTitle -> Int64 -> Int64 -> Text -> ReaderT SqlBackend m [P.Entity SApp] searchServices :: MonadIO m => Maybe CategoryTitle -> Int64 -> Int64 -> Text -> ReaderT SqlBackend m [P.Entity SApp]
searchServices Nothing pageItems offset' query = select $ do searchServices Nothing pageItems offset' query = select $ do
service <- from $ table @SApp service <- from $ table @SApp
where_ ((service ^. SAppDescShort `ilike` (%) ++. val query ++. (%)) where_
||. (service ^. SAppDescLong `ilike` (%) ++. val query ++. (%)) ( (service ^. SAppDescShort `ilike` (%) ++. val query ++. (%))
||. (service ^. SAppTitle `ilike` (%) ++. val query ++. (%)) ||. (service ^. SAppDescLong `ilike` (%) ++. val query ++. (%))
||. (service ^. SAppAppId `ilike` (%) ++. val query ++. (%))) ||. (service ^. SAppTitle `ilike` (%) ++. val query ++. (%))
orderBy [ desc (service ^. SAppUpdatedAt) ] ||. (service ^. SAppAppId `ilike` (%) ++. val query ++. (%))
limit pageItems )
offset offset' orderBy [desc (service ^. SAppUpdatedAt)]
pure service limit pageItems
offset offset'
pure service
searchServices (Just category) pageItems offset' query = select $ do searchServices (Just category) pageItems offset' query = select $ do
services <- from services <- from
(do (do
(service :& sc) <- (service :& sc) <-
from $ table @SApp from
$ table @SApp
`innerJoin` table @ServiceCategory `innerJoin` table @ServiceCategory
`on` (\(s :& sc) -> `on` (\(s :& sc) -> sc ^. ServiceCategoryServiceId ==. s ^. SAppId)
sc ^. ServiceCategoryServiceId ==. s ^. SAppId)
-- if there is a cateogry, only search in category -- if there is a cateogry, only search in category
-- weight title, short, long (bitcoin should equal Bitcoin Core) -- weight title, short, long (bitcoin should equal Bitcoin Core)
where_ $ sc ^. ServiceCategoryCategoryName ==. val category where_
&&. ((service ^. SAppDescShort `ilike` (%) ++. val query ++. (%)) $ sc
^. ServiceCategoryCategoryName
==. val category
&&. ( (service ^. SAppDescShort `ilike` (%) ++. val query ++. (%))
||. (service ^. SAppDescLong `ilike` (%) ++. val query ++. (%)) ||. (service ^. SAppDescLong `ilike` (%) ++. val query ++. (%))
||. (service ^. SAppTitle `ilike` (%) ++. val query ++. (%)) ||. (service ^. SAppTitle `ilike` (%) ++. val query ++. (%))
||. (service ^. SAppAppId `ilike` (%) ++. val query ++. (%)) ||. (service ^. SAppAppId `ilike` (%) ++. val query ++. (%))
) )
pure service pure service
) )
orderBy [ desc (services ^. SAppUpdatedAt) ] orderBy [desc (services ^. SAppUpdatedAt)]
limit pageItems limit pageItems
offset offset' offset offset'
pure services pure services
@@ -51,7 +59,7 @@ newtype VersionsWithReleaseNotes = VersionsWithReleaseNotes (HashMap Version Tex
instance FromJSON VersionsWithReleaseNotes instance FromJSON VersionsWithReleaseNotes
instance PersistField VersionsWithReleaseNotes where instance PersistField VersionsWithReleaseNotes where
fromPersistValue = fromPersistValueJSON fromPersistValue = fromPersistValueJSON
toPersistValue = PersistText . show toPersistValue = PersistText . show
-- in progress attempt to do postgres aggregation with raw sql in esqueleto -- in progress attempt to do postgres aggregation with raw sql in esqueleto
-- getServiceVersionsWithReleaseNotes :: MonadIO m => Text -> ReaderT SqlBackend m (Entity SApp) -- getServiceVersionsWithReleaseNotes :: MonadIO m => Text -> ReaderT SqlBackend m (Entity SApp)

4
src/Handler/Apps.hs
View File

@@ -9,7 +9,7 @@
module Handler.Apps where module Handler.Apps where
import Startlude hiding (Handler) import Startlude hiding ( Handler )
import Control.Monad.Logger import Control.Monad.Logger
import Data.Aeson import Data.Aeson
@@ -74,7 +74,7 @@ getSysR e = do
getAppManifestR :: AppIdentifier -> Handler TypedContent getAppManifestR :: AppIdentifier -> Handler TypedContent
getAppManifestR appId = do getAppManifestR appId = do
(appsDir, appMgrDir) <- getsYesod $ ((</> "apps") . resourcesDir &&& staticBinDir) . appSettings (appsDir, appMgrDir) <- getsYesod $ ((</> "apps") . resourcesDir &&& staticBinDir) . appSettings
av <- getVersionFromQuery appsDir appExt >>= \case av <- getVersionFromQuery appsDir appExt >>= \case
Nothing -> sendResponseStatus status404 ("Specified App Version Not Found" :: Text) Nothing -> sendResponseStatus status404 ("Specified App Version Not Found" :: Text)
Just v -> pure v Just v -> pure v
let appDir = (<> "/") . (</> show av) . (</> toS appId) $ appsDir let appDir = (<> "/") . (</> show av) . (</> toS appId) $ appsDir

14
src/Handler/Icons.hs
View File

@@ -36,7 +36,7 @@ ixt = toS $ toUpper <$> drop 1 ".png"
getIconsR :: AppIdentifier -> Handler TypedContent getIconsR :: AppIdentifier -> Handler TypedContent
getIconsR appId = do getIconsR appId = do
(appsDir, appMgrDir) <- getsYesod $ ((</> "apps") . resourcesDir &&& staticBinDir) . appSettings (appsDir, appMgrDir) <- getsYesod $ ((</> "apps") . resourcesDir &&& staticBinDir) . appSettings
spec <- getVersionFromQuery appsDir ext >>= \case spec <- getVersionFromQuery appsDir ext >>= \case
Nothing -> sendResponseStatus status404 ("Specified App Version Not Found" :: Text) Nothing -> sendResponseStatus status404 ("Specified App Version Not Found" :: Text)
Just v -> pure v Just v -> pure v
let appDir = (<> "/") . (</> show spec) . (</> toS appId) $ appsDir let appDir = (<> "/") . (</> show spec) . (</> toS appId) $ appsDir
@@ -57,10 +57,10 @@ getIconsR appId = do
$logInfo $ "unknown icon extension type: " <> show x <> ". Sending back typePlain." $logInfo $ "unknown icon extension type: " <> show x <> ". Sending back typePlain."
pure typePlain pure typePlain
Just iconType -> case iconType of Just iconType -> case iconType of
PNG -> pure typePng PNG -> pure typePng
SVG -> pure typeSvg SVG -> pure typeSvg
JPG -> pure typeJpeg JPG -> pure typeJpeg
JPEG -> pure typeJpeg JPEG -> pure typeJpeg
respondSource mimeType (sendChunkBS =<< handleS9ErrT (getIcon appMgrDir (appDir </> show ext) ext)) respondSource mimeType (sendChunkBS =<< handleS9ErrT (getIcon appMgrDir (appDir </> show ext) ext))
-- (_, Just hout, _, _) <- liftIO (createProcess $ iconBs { std_out = CreatePipe }) -- (_, Just hout, _, _) <- liftIO (createProcess $ iconBs { std_out = CreatePipe })
-- respondSource typePlain (runConduit $ yieldMany () [iconBs]) -- respondSource typePlain (runConduit $ yieldMany () [iconBs])
@@ -70,7 +70,7 @@ getIconsR appId = do
getLicenseR :: AppIdentifier -> Handler TypedContent getLicenseR :: AppIdentifier -> Handler TypedContent
getLicenseR appId = do getLicenseR appId = do
(appsDir, appMgrDir) <- getsYesod $ ((</> "apps") . resourcesDir &&& staticBinDir) . appSettings (appsDir, appMgrDir) <- getsYesod $ ((</> "apps") . resourcesDir &&& staticBinDir) . appSettings
spec <- getVersionFromQuery appsDir ext >>= \case spec <- getVersionFromQuery appsDir ext >>= \case
Nothing -> sendResponseStatus status404 ("Specified App Version Not Found" :: Text) Nothing -> sendResponseStatus status404 ("Specified App Version Not Found" :: Text)
Just v -> pure v Just v -> pure v
servicePath <- liftIO $ getVersionedFileFromDir appsDir ext spec servicePath <- liftIO $ getVersionedFileFromDir appsDir ext spec
@@ -83,7 +83,7 @@ getLicenseR appId = do
getInstructionsR :: AppIdentifier -> Handler TypedContent getInstructionsR :: AppIdentifier -> Handler TypedContent
getInstructionsR appId = do getInstructionsR appId = do
(appsDir, appMgrDir) <- getsYesod $ ((</> "apps") . resourcesDir &&& staticBinDir) . appSettings (appsDir, appMgrDir) <- getsYesod $ ((</> "apps") . resourcesDir &&& staticBinDir) . appSettings
spec <- getVersionFromQuery appsDir ext >>= \case spec <- getVersionFromQuery appsDir ext >>= \case
Nothing -> sendResponseStatus status404 ("Specified App Version Not Found" :: Text) Nothing -> sendResponseStatus status404 ("Specified App Version Not Found" :: Text)
Just v -> pure v Just v -> pure v
servicePath <- liftIO $ getVersionedFileFromDir appsDir ext spec servicePath <- liftIO $ getVersionedFileFromDir appsDir ext spec

396
src/Handler/Marketplace.hs
View File

@@ -10,31 +10,35 @@
module Handler.Marketplace where module Handler.Marketplace where
import Startlude hiding (from, Handler, on, sortOn) import Startlude hiding ( from
import Foundation , Handler
import Yesod.Core , on
import qualified Database.Persist as P , sortOn
import Model )
import Yesod.Persist.Core import Foundation
import Database.Marketplace import Yesod.Core
import Data.List import qualified Database.Persist as P
import Lib.Types.Category import Model
import Lib.Types.AppIndex import Yesod.Persist.Core
import qualified Data.HashMap.Strict as HM import Database.Marketplace
import Lib.Types.Emver import Data.List
import qualified Data.List.NonEmpty as NE import Lib.Types.Category
import Database.Esqueleto.Experimental import Lib.Types.AppIndex
import Lib.Error import qualified Data.HashMap.Strict as HM
import Network.HTTP.Types import Lib.Types.Emver
import Lib.Registry import qualified Data.List.NonEmpty as NE
import Settings import Database.Esqueleto.Experimental
import System.FilePath.Posix import Lib.Error
import Lib.External.AppMgr import Network.HTTP.Types
import Data.Aeson import Lib.Registry
import qualified Data.ByteString.Lazy as BS import Settings
import qualified Data.Text as T import System.FilePath.Posix
import Data.String.Interpolate.IsString import Lib.External.AppMgr
import Util.Shared import Data.Aeson
import qualified Data.ByteString.Lazy as BS
import qualified Data.Text as T
import Data.String.Interpolate.IsString
import Util.Shared
newtype CategoryRes = CategoryRes { newtype CategoryRes = CategoryRes {
categories :: [CategoryTitle] categories :: [CategoryTitle]
@@ -58,7 +62,7 @@ data ServiceRes = ServiceRes
newtype ReleaseNotes = ReleaseNotes { unReleaseNotes :: HM.HashMap Version Text } newtype ReleaseNotes = ReleaseNotes { unReleaseNotes :: HM.HashMap Version Text }
deriving (Eq, Show) deriving (Eq, Show)
instance ToJSON ReleaseNotes where instance ToJSON ReleaseNotes where
toJSON ReleaseNotes { .. } = object [ t .= v | (k,v) <- HM.toList unReleaseNotes, let (String t) = toJSON k ] toJSON ReleaseNotes {..} = object [ t .= v | (k, v) <- HM.toList unReleaseNotes, let (String t) = toJSON k ]
instance ToContent ReleaseNotes where instance ToContent ReleaseNotes where
toContent = toContent . toJSON toContent = toContent . toJSON
instance ToTypedContent ReleaseNotes where instance ToTypedContent ReleaseNotes where
@@ -82,20 +86,15 @@ data DependencyInfo = DependencyInfo
, dependencyInfoIcon :: Text -- url , dependencyInfoIcon :: Text -- url
} deriving (Eq, Show) } deriving (Eq, Show)
instance ToJSON DependencyInfo where instance ToJSON DependencyInfo where
toJSON DependencyInfo {..} = object toJSON DependencyInfo {..} = object ["icon" .= dependencyInfoIcon, "title" .= dependencyInfoTitle]
[ "icon" .= dependencyInfoIcon
, "title" .= dependencyInfoTitle
]
data ServiceListRes = ServiceListRes { data ServiceListRes = ServiceListRes {
serviceListResCategories :: [CategoryTitle] serviceListResCategories :: [CategoryTitle]
, serviceListResServices :: [ServiceAvailable] , serviceListResServices :: [ServiceAvailable]
} deriving (Show) } deriving (Show)
instance ToJSON ServiceListRes where instance ToJSON ServiceListRes where
toJSON ServiceListRes {..} = object toJSON ServiceListRes {..} =
[ "categories" .= serviceListResCategories object ["categories" .= serviceListResCategories, "services" .= serviceListResServices]
, "services" .= serviceListResServices
]
instance ToContent ServiceListRes where instance ToContent ServiceListRes where
toContent = toContent . toJSON toContent = toContent . toJSON
instance ToTypedContent ServiceListRes where instance ToTypedContent ServiceListRes where
@@ -109,7 +108,7 @@ data ServiceAvailable = ServiceAvailable
, serviceAvailableDescShort :: Text , serviceAvailableDescShort :: Text
} deriving (Show) } deriving (Show)
instance ToJSON ServiceAvailable where instance ToJSON ServiceAvailable where
toJSON ServiceAvailable { .. } = object toJSON ServiceAvailable {..} = object
[ "id" .= serviceAvailableId [ "id" .= serviceAvailableId
, "title" .= serviceAvailableTitle , "title" .= serviceAvailableTitle
, "version" .= serviceAvailableVersion , "version" .= serviceAvailableVersion
@@ -152,11 +151,8 @@ data EosRes = EosRes
, eosResReleaseNotes :: ReleaseNotes , eosResReleaseNotes :: ReleaseNotes
} deriving (Eq, Show, Generic) } deriving (Eq, Show, Generic)
instance ToJSON EosRes where instance ToJSON EosRes where
toJSON EosRes { .. } = object toJSON EosRes {..} =
[ "version" .= eosResVersion object ["version" .= eosResVersion, "headline" .= eosResHeadline, "release-notes" .= eosResReleaseNotes]
, "headline" .= eosResHeadline
, "release-notes" .= eosResReleaseNotes
]
instance ToContent EosRes where instance ToContent EosRes where
toContent = toContent . toJSON toContent = toContent . toJSON
instance ToTypedContent EosRes where instance ToTypedContent EosRes where
@@ -168,7 +164,7 @@ data PackageVersion = PackageVersion
} deriving (Show) } deriving (Show)
instance FromJSON PackageVersion where instance FromJSON PackageVersion where
parseJSON = withObject "package version" $ \o -> do parseJSON = withObject "package version" $ \o -> do
packageVersionId <- o .: "id" packageVersionId <- o .: "id"
packageVersionVersion <- o .: "version" packageVersionVersion <- o .: "version"
pure PackageVersion { .. } pure PackageVersion { .. }
@@ -178,7 +174,7 @@ getCategoriesR = do
cats <- from $ table @Category cats <- from $ table @Category
orderBy [desc (cats ^. CategoryPriority)] orderBy [desc (cats ^. CategoryPriority)]
pure cats pure cats
pure $ CategoryRes $ categoryName . entityVal <$>allCategories pure $ CategoryRes $ categoryName . entityVal <$> allCategories
getEosR :: Handler EosRes getEosR :: Handler EosRes
getEosR = do getEosR = do
@@ -186,71 +182,85 @@ getEosR = do
vers <- from $ table @OsVersion vers <- from $ table @OsVersion
orderBy [desc (vers ^. OsVersionCreatedAt)] orderBy [desc (vers ^. OsVersionCreatedAt)]
pure vers pure vers
let osV = entityVal <$> allEosVersions let osV = entityVal <$> allEosVersions
let latest = Data.List.head osV let latest = Data.List.head osV
let mappedVersions = ReleaseNotes $ HM.fromList $ sortOn (Down . fst) $ (\v -> (osVersionNumber v, osVersionReleaseNotes v)) <$> osV let mappedVersions =
pure $ EosRes ReleaseNotes
{ eosResVersion = osVersionNumber latest $ HM.fromList
, eosResHeadline = osVersionHeadline latest $ sortOn (Down . fst)
, eosResReleaseNotes = mappedVersions $ (\v -> (osVersionNumber v, osVersionReleaseNotes v))
} <$> osV
pure $ EosRes { eosResVersion = osVersionNumber latest
, eosResHeadline = osVersionHeadline latest
, eosResReleaseNotes = mappedVersions
}
getReleaseNotesR :: Handler ReleaseNotes getReleaseNotesR :: Handler ReleaseNotes
getReleaseNotesR = do getReleaseNotesR = do
getParameters <- reqGetParams <$> getRequest getParameters <- reqGetParams <$> getRequest
case lookup "id" getParameters of case lookup "id" getParameters of
Nothing -> sendResponseStatus status400 ("expected query param \"id\" to exist" :: Text) Nothing -> sendResponseStatus status400 ("expected query param \"id\" to exist" :: Text)
Just package -> do Just package -> do
(service, _) <- runDB $ fetchLatestApp package >>= errOnNothing status404 "package not found" (service, _ ) <- runDB $ fetchLatestApp package >>= errOnNothing status404 "package not found"
(_, mappedVersions) <- fetchAllAppVersions (entityKey service) (_ , mappedVersions) <- fetchAllAppVersions (entityKey service)
pure mappedVersions pure mappedVersions
getVersionLatestR :: Handler VersionLatestRes getVersionLatestR :: Handler VersionLatestRes
getVersionLatestR = do getVersionLatestR = do
getParameters <- reqGetParams <$> getRequest getParameters <- reqGetParams <$> getRequest
case lookup "ids" getParameters of case lookup "ids" getParameters of
Nothing -> sendResponseStatus status400 ("expected query param \"ids\" to exist" :: Text) Nothing -> sendResponseStatus status400 ("expected query param \"ids\" to exist" :: Text)
Just packages -> case eitherDecode $ BS.fromStrict $ encodeUtf8 packages of Just packages -> case eitherDecode $ BS.fromStrict $ encodeUtf8 packages of
Left e -> sendResponseStatus status400 ("could not parse query param \"ids\"" <> show e :: Text) Left e -> sendResponseStatus status400 ("could not parse query param \"ids\"" <> show e :: Text)
Right (p :: [AppIdentifier])-> do Right (p :: [AppIdentifier]) -> do
let packageList :: [(AppIdentifier, Maybe Version)] = (, Nothing) <$> p let packageList :: [(AppIdentifier, Maybe Version)] = (, Nothing) <$> p
found <- runDB $ traverse fetchLatestApp $ fst <$> packageList found <- runDB $ traverse fetchLatestApp $ fst <$> packageList
pure $ VersionLatestRes $ HM.union (HM.fromList $ (\v -> (sAppAppId $ entityVal $ fst v :: AppIdentifier, Just $ sVersionNumber $ entityVal $ snd v)) <$> catMaybes found) $ HM.fromList packageList pure
$ VersionLatestRes
$ HM.union
( HM.fromList
$ (\v ->
( sAppAppId $ entityVal $ fst v :: AppIdentifier
, Just $ sVersionNumber $ entityVal $ snd v
)
)
<$> catMaybes found
)
$ HM.fromList packageList
getPackageListR :: Handler ServiceAvailableRes getPackageListR :: Handler ServiceAvailableRes
getPackageListR = do getPackageListR = do
getParameters <- reqGetParams <$> getRequest getParameters <- reqGetParams <$> getRequest
let defaults = ServiceListDefaults let defaults = ServiceListDefaults { serviceListOrder = DESC
{ serviceListOrder = DESC , serviceListPageLimit = 20
, serviceListPageLimit = 20 , serviceListPageNumber = 1
, serviceListPageNumber = 1 , serviceListCategory = Nothing
, serviceListCategory = Nothing , serviceListQuery = ""
, serviceListQuery = "" }
}
case lookup "ids" getParameters of case lookup "ids" getParameters of
Nothing -> do Nothing -> do
-- query for all -- query for all
category <- case lookup "category" getParameters of category <- case lookup "category" getParameters of
Nothing -> pure $ serviceListCategory defaults Nothing -> pure $ serviceListCategory defaults
Just c -> case readMaybe $ T.toUpper c of Just c -> case readMaybe $ T.toUpper c of
Nothing -> do Nothing -> do
$logInfo c $logInfo c
sendResponseStatus status400 ("could not read category" :: Text) sendResponseStatus status400 ("could not read category" :: Text)
Just t -> pure $ Just t Just t -> pure $ Just t
page <- case lookup "page" getParameters of page <- case lookup "page" getParameters of
Nothing -> pure $ serviceListPageNumber defaults Nothing -> pure $ serviceListPageNumber defaults
Just p -> case readMaybe p of Just p -> case readMaybe p of
Nothing -> do Nothing -> do
$logInfo p $logInfo p
sendResponseStatus status400 ("could not read page" :: Text) sendResponseStatus status400 ("could not read page" :: Text)
Just t -> pure $ case t of Just t -> pure $ case t of
0 -> 1 -- disallow page 0 so offset is not negative 0 -> 1 -- disallow page 0 so offset is not negative
_ -> t _ -> t
limit' <- case lookup "per-page" getParameters of limit' <- case lookup "per-page" getParameters of
Nothing -> pure $ serviceListPageLimit defaults Nothing -> pure $ serviceListPageLimit defaults
Just c -> case readMaybe $ toS c of Just c -> case readMaybe $ toS c of
Nothing -> sendResponseStatus status400 ("could not read per-page" :: Text) Nothing -> sendResponseStatus status400 ("could not read per-page" :: Text)
Just l -> pure l Just l -> pure l
query <- T.filter (not . isSpace) . fromMaybe (serviceListQuery defaults) <$> lookupGetParam "query" query <- T.filter (not . isSpace) . fromMaybe (serviceListQuery defaults) <$> lookupGetParam "query"
filteredServices <- runDB $ searchServices category limit' ((page - 1) * limit') query filteredServices <- runDB $ searchServices category limit' ((page - 1) * limit') query
-- domain <- getsYesod $ registryHostname . appSettings -- domain <- getsYesod $ registryHostname . appSettings
@@ -260,84 +270,95 @@ getPackageListR = do
pure $ ServiceAvailableRes res pure $ ServiceAvailableRes res
Just packageVersionList -> case eitherDecode $ BS.fromStrict $ encodeUtf8 packageVersionList of Just packageVersionList -> case eitherDecode $ BS.fromStrict $ encodeUtf8 packageVersionList of
Left e -> sendResponseStatus status400 ("could not parse query param \"ids\"" <> show e :: Text) Left e -> sendResponseStatus status400 ("could not parse query param \"ids\"" <> show e :: Text)
Right (packages :: [PackageVersion])-> do Right (packages :: [PackageVersion]) -> do
-- for each item in list get best available from version range -- for each item in list get best available from version range
availableServices <- traverse getPackageDetails packages availableServices <- traverse getPackageDetails packages
services <- traverse (uncurry getServiceDetails) availableServices services <- traverse (uncurry getServiceDetails) availableServices
pure $ ServiceAvailableRes services pure $ ServiceAvailableRes services
where where
getPackageDetails :: PackageVersion -> HandlerFor RegistryCtx (Maybe (Entity SVersion), Entity SApp) getPackageDetails :: PackageVersion -> HandlerFor RegistryCtx (Maybe (Entity SVersion), Entity SApp)
getPackageDetails pv = do getPackageDetails pv = do
appsDir <- getsYesod $ ((</> "apps") . resourcesDir) . appSettings appsDir <- getsYesod $ ((</> "apps") . resourcesDir) . appSettings
let appId = packageVersionId pv let appId = packageVersionId pv
let spec = packageVersionVersion pv let spec = packageVersionVersion pv
let appExt = Extension (toS appId) :: Extension "s9pk" let appExt = Extension (toS appId) :: Extension "s9pk"
getBestVersion appsDir appExt spec >>= \case getBestVersion appsDir appExt spec >>= \case
Nothing -> sendResponseStatus status404 ("best version could not be found for " <> appId <> " with spec " <> show spec :: Text) Nothing -> sendResponseStatus
status404
("best version could not be found for " <> appId <> " with spec " <> show spec :: Text)
Just v -> do Just v -> do
(service, version) <- runDB $ fetchLatestAppAtVersion appId v >>= errOnNothing status404 ("service at version " <> show v <> " not found") (service, version) <- runDB $ fetchLatestAppAtVersion appId v >>= errOnNothing
status404
("service at version " <> show v <> " not found")
pure (Just version, service) pure (Just version, service)
getServiceR :: Handler ServiceRes getServiceR :: Handler ServiceRes
getServiceR = do getServiceR = do
getParameters <- reqGetParams <$> getRequest getParameters <- reqGetParams <$> getRequest
(service, version) <- case lookup "id" getParameters of (service, version) <- case lookup "id" getParameters of
Nothing -> sendResponseStatus status404 ("id param should exist" :: Text) Nothing -> sendResponseStatus status404 ("id param should exist" :: Text)
Just appId' -> do Just appId' -> do
case lookup "version" getParameters of case lookup "version" getParameters of
-- default to latest - @TODO need to determine best available based on OS version? -- default to latest - @TODO need to determine best available based on OS version?
Nothing -> runDB $ fetchLatestApp appId' >>= errOnNothing status404 "service not found" Nothing -> runDB $ fetchLatestApp appId' >>= errOnNothing status404 "service not found"
Just v -> do Just v -> do
case readMaybe v of case readMaybe v of
Nothing -> sendResponseStatus status400 ("Invalid App Version Specification" :: Text) Nothing -> sendResponseStatus status400 ("Invalid App Version Specification" :: Text)
Just vv -> runDB $ fetchLatestAppAtVersion appId' vv >>= errOnNothing status404 ("service at version " <> show v <> " not found") Just vv -> runDB $ fetchLatestAppAtVersion appId' vv >>= errOnNothing
status404
("service at version " <> show v <> " not found")
getServiceDetails (Just version) service getServiceDetails (Just version) service
getServiceDetails :: Maybe (Entity SVersion) -> Entity SApp -> HandlerFor RegistryCtx ServiceRes getServiceDetails :: Maybe (Entity SVersion) -> Entity SApp -> HandlerFor RegistryCtx ServiceRes
getServiceDetails maybeVersion service = do getServiceDetails maybeVersion service = do
(versions, _) <- fetchAllAppVersions (entityKey service) (versions, _) <- fetchAllAppVersions (entityKey service)
categories <- runDB $ fetchAppCategories (entityKey service) categories <- runDB $ fetchAppCategories (entityKey service)
(appsDir, appMgrDir) <- getsYesod $ ((</> "apps") . resourcesDir &&& staticBinDir) . appSettings (appsDir, appMgrDir) <- getsYesod $ ((</> "apps") . resourcesDir &&& staticBinDir) . appSettings
domain <- getsYesod $ registryHostname . appSettings domain <- getsYesod $ registryHostname . appSettings
let appId = sAppAppId $ entityVal service let appId = sAppAppId $ entityVal service
version <- case maybeVersion of version <- case maybeVersion of
Nothing -> do Nothing -> do
(_, version) <- runDB $ fetchLatestApp appId >>= errOnNothing status404 "service not found" (_, version) <- runDB $ fetchLatestApp appId >>= errOnNothing status404 "service not found"
pure $ sVersionNumber $ entityVal version pure $ sVersionNumber $ entityVal version
Just v -> pure $ sVersionNumber $ entityVal v Just v -> pure $ sVersionNumber $ entityVal v
let appDir = (<> "/") . (</> show version) . (</> toS appId) $ appsDir let appDir = (<> "/") . (</> show version) . (</> toS appId) $ appsDir
let appExt = Extension (toS appId) :: Extension "s9pk" let appExt = Extension (toS appId) :: Extension "s9pk"
manifest' <- handleS9ErrT $ getManifest appMgrDir appDir appExt manifest' <- handleS9ErrT $ getManifest appMgrDir appDir appExt
manifest <- case eitherDecode $ BS.fromStrict manifest' of manifest <- case eitherDecode $ BS.fromStrict manifest' of
Left e -> do Left e -> do
$logError "could not parse service manifest!" $logError "could not parse service manifest!"
$logError (show e) $logError (show e)
sendResponseStatus status500 ("Internal Server Error" :: Text) sendResponseStatus status500 ("Internal Server Error" :: Text)
Right a -> pure a Right a -> pure a
d <- traverse (mapDependencyMetadata appsDir domain) (HM.toList $ serviceManifestDependencies manifest) d <- traverse (mapDependencyMetadata appsDir domain) (HM.toList $ serviceManifestDependencies manifest)
pure $ ServiceRes pure $ ServiceRes { serviceResIcon = [i|https://#{domain}/package/icon/#{appId}|]
{ serviceResIcon = [i|https://#{domain}/package/icon/#{appId}|] , serviceResManifest = decode $ BS.fromStrict manifest' -- pass through raw JSON Value
, serviceResManifest = decode $ BS.fromStrict manifest' -- pass through raw JSON Value , serviceResCategories = serviceCategoryCategoryName . entityVal <$> categories
, serviceResCategories = serviceCategoryCategoryName . entityVal <$> categories , serviceResInstructions = [i|https://#{domain}/package/instructions/#{appId}|]
, serviceResInstructions = [i|https://#{domain}/package/instructions/#{appId}|] , serviceResLicense = [i|https://#{domain}/package/license/#{appId}|]
, serviceResLicense = [i|https://#{domain}/package/license/#{appId}|] , serviceResVersions = versionInfoVersion <$> versions
, serviceResVersions = versionInfoVersion <$> versions , serviceResDependencyInfo = HM.fromList d
, serviceResDependencyInfo = HM.fromList d }
}
type URL = Text type URL = Text
mapDependencyMetadata :: (MonadIO m, MonadHandler m) => FilePath -> Text -> (AppIdentifier, ServiceDependencyInfo) -> m (AppIdentifier, DependencyInfo) mapDependencyMetadata :: (MonadIO m, MonadHandler m)
=> FilePath
-> Text
-> (AppIdentifier, ServiceDependencyInfo)
-> m (AppIdentifier, DependencyInfo)
mapDependencyMetadata appsDir domain (appId, depInfo) = do mapDependencyMetadata appsDir domain (appId, depInfo) = do
let ext = (Extension (toS appId) :: Extension "s9pk") let ext = (Extension (toS appId) :: Extension "s9pk")
-- get best version from VersionRange of dependency -- get best version from VersionRange of dependency
version <- getBestVersion appsDir ext (serviceDependencyInfoVersion depInfo) >>= \case version <- getBestVersion appsDir ext (serviceDependencyInfoVersion depInfo) >>= \case
Nothing -> sendResponseStatus status404 ("best version not found for dependent package " <> appId :: Text) Nothing -> sendResponseStatus status404 ("best version not found for dependent package " <> appId :: Text)
Just v -> pure v Just v -> pure v
pure (appId, DependencyInfo pure
{ dependencyInfoTitle = appId ( appId
, dependencyInfoIcon = [i|https://#{domain}/package/icon/#{appId}?spec==#{version}|] , DependencyInfo { dependencyInfoTitle = appId
}) , dependencyInfoIcon = [i|https://#{domain}/package/icon/#{appId}?spec==#{version}|]
}
)
decodeIcon :: (MonadHandler m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> m URL decodeIcon :: (MonadHandler m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> m URL
decodeIcon appmgrPath depPath e@(Extension icon) = do decodeIcon appmgrPath depPath e@(Extension icon) = do
@@ -361,83 +382,86 @@ decodeLicense appmgrPath depPath package = do
fetchAllAppVersions :: Key SApp -> HandlerFor RegistryCtx ([VersionInfo], ReleaseNotes) fetchAllAppVersions :: Key SApp -> HandlerFor RegistryCtx ([VersionInfo], ReleaseNotes)
fetchAllAppVersions appId = do fetchAllAppVersions appId = do
entityAppVersions <- runDB $ P.selectList [SVersionAppId P.==. appId] [] -- orderby version entityAppVersions <- runDB $ P.selectList [SVersionAppId P.==. appId] [] -- orderby version
let vers = entityVal <$> entityAppVersions let vers = entityVal <$> entityAppVersions
let vv = mapSVersionToVersionInfo vers let vv = mapSVersionToVersionInfo vers
let mappedVersions = ReleaseNotes $ HM.fromList $ (\v -> (versionInfoVersion v, versionInfoReleaseNotes v)) <$> vv let mappedVersions = ReleaseNotes $ HM.fromList $ (\v -> (versionInfoVersion v, versionInfoReleaseNotes v)) <$> vv
pure (vv, mappedVersions) pure (vv, mappedVersions)
fetchMostRecentAppVersions :: MonadIO m => Key SApp -> ReaderT SqlBackend m [Entity SVersion] fetchMostRecentAppVersions :: MonadIO m => Key SApp -> ReaderT SqlBackend m [Entity SVersion]
fetchMostRecentAppVersions appId = select $ do fetchMostRecentAppVersions appId = select $ do
version <- from $ table @SVersion version <- from $ table @SVersion
where_ (version ^. SVersionAppId ==. val appId) where_ (version ^. SVersionAppId ==. val appId)
orderBy [ desc (version ^. SVersionNumber) ] orderBy [desc (version ^. SVersionNumber)]
limit 1 limit 1
pure version pure version
fetchLatestApp :: MonadIO m => Text -> ReaderT SqlBackend m (Maybe (P.Entity SApp, P.Entity SVersion)) fetchLatestApp :: MonadIO m => Text -> ReaderT SqlBackend m (Maybe (P.Entity SApp, P.Entity SVersion))
fetchLatestApp appId = selectOne $ do fetchLatestApp appId = selectOne $ do
(service :& version) <- (service :& version) <-
from $ table @SApp from
`innerJoin` table @SVersion $ table @SApp
`on` (\(service :& version) -> `innerJoin` table @SVersion
service ^. SAppId ==. version ^. SVersionAppId) `on` (\(service :& version) -> service ^. SAppId ==. version ^. SVersionAppId)
where_ (service ^. SAppAppId ==. val appId) where_ (service ^. SAppAppId ==. val appId)
orderBy [ desc (version ^. SVersionNumber)] orderBy [desc (version ^. SVersionNumber)]
pure (service, version) pure (service, version)
fetchLatestAppAtVersion :: MonadIO m => Text -> Version -> ReaderT SqlBackend m (Maybe (P.Entity SApp, P.Entity SVersion)) fetchLatestAppAtVersion :: MonadIO m
=> Text
-> Version
-> ReaderT SqlBackend m (Maybe (P.Entity SApp, P.Entity SVersion))
fetchLatestAppAtVersion appId version' = selectOne $ do fetchLatestAppAtVersion appId version' = selectOne $ do
(service :& version) <- (service :& version) <-
from $ table @SApp from
`innerJoin` table @SVersion $ table @SApp
`on` (\(service :& version) -> `innerJoin` table @SVersion
service ^. SAppId ==. version ^. SVersionAppId) `on` (\(service :& version) -> service ^. SAppId ==. version ^. SVersionAppId)
where_ $ (service ^. SAppAppId ==. val appId) where_ $ (service ^. SAppAppId ==. val appId) &&. (version ^. SVersionNumber ==. val version')
&&. (version ^. SVersionNumber ==. val version') pure (service, version)
pure (service, version)
fetchAppCategories :: MonadIO m => Key SApp -> ReaderT SqlBackend m [P.Entity ServiceCategory] fetchAppCategories :: MonadIO m => Key SApp -> ReaderT SqlBackend m [P.Entity ServiceCategory]
fetchAppCategories appId = select $ do fetchAppCategories appId = select $ do
(categories :& service) <- (categories :& service) <-
from $ table @ServiceCategory from
`innerJoin` table @SApp $ table @ServiceCategory
`on` (\(sc :& s) -> `innerJoin` table @SApp
sc ^. ServiceCategoryServiceId ==. s ^. SAppId) `on` (\(sc :& s) -> sc ^. ServiceCategoryServiceId ==. s ^. SAppId)
where_ (service ^. SAppId ==. val appId) where_ (service ^. SAppId ==. val appId)
pure categories pure categories
mapEntityToStoreApp :: MonadIO m => Entity SApp -> ReaderT SqlBackend m StoreApp mapEntityToStoreApp :: MonadIO m => Entity SApp -> ReaderT SqlBackend m StoreApp
mapEntityToStoreApp serviceEntity = do mapEntityToStoreApp serviceEntity = do
let service = entityVal serviceEntity let service = entityVal serviceEntity
entityVersion <- fetchMostRecentAppVersions $ entityKey serviceEntity entityVersion <- fetchMostRecentAppVersions $ entityKey serviceEntity
let vers = entityVal <$> entityVersion let vers = entityVal <$> entityVersion
let vv = mapSVersionToVersionInfo vers let vv = mapSVersionToVersionInfo vers
pure $ StoreApp { pure $ StoreApp { storeAppTitle = sAppTitle service
storeAppTitle = sAppTitle service , storeAppDescShort = sAppDescShort service
, storeAppDescShort = sAppDescShort service , storeAppDescLong = sAppDescLong service
, storeAppDescLong = sAppDescLong service , storeAppVersionInfo = NE.fromList vv
, storeAppVersionInfo = NE.fromList vv , storeAppIconType = sAppIconType service
, storeAppIconType = sAppIconType service , storeAppTimestamp = Just (sAppCreatedAt service) -- case on if updatedAt? or always use updated time? was file timestamp
, storeAppTimestamp = Just (sAppCreatedAt service) -- case on if updatedAt? or always use updated time? was file timestamp }
}
mapEntityToServiceAvailable :: (MonadIO m, MonadHandler m) => Text -> Entity SApp -> ReaderT SqlBackend m ServiceAvailable mapEntityToServiceAvailable :: (MonadIO m, MonadHandler m)
=> Text
-> Entity SApp
-> ReaderT SqlBackend m ServiceAvailable
mapEntityToServiceAvailable domain service = do mapEntityToServiceAvailable domain service = do
let appId = sAppAppId $ entityVal service let appId = sAppAppId $ entityVal service
(_, v) <- fetchLatestApp appId >>= errOnNothing status404 "service not found" (_, v) <- fetchLatestApp appId >>= errOnNothing status404 "service not found"
let appVersion = sVersionNumber (entityVal v) let appVersion = sVersionNumber (entityVal v)
pure $ ServiceAvailable pure $ ServiceAvailable { serviceAvailableId = appId
{ serviceAvailableId = appId , serviceAvailableTitle = sAppTitle $ entityVal service
, serviceAvailableTitle = sAppTitle $ entityVal service , serviceAvailableDescShort = sAppDescShort $ entityVal service
, serviceAvailableDescShort = sAppDescShort $ entityVal service , serviceAvailableVersion = appVersion
, serviceAvailableVersion = appVersion , serviceAvailableIcon = [i|https://#{domain}/package/icon/#{appId}?spec==#{appVersion}|]
, serviceAvailableIcon = [i|https://#{domain}/package/icon/#{appId}?spec==#{appVersion}|] }
}
-- >>> encode hm -- >>> encode hm
-- "{\"0.2.0\":\"some notes\"}" -- "{\"0.2.0\":\"some notes\"}"
hm :: Data.Aeson.Value hm :: Data.Aeson.Value
hm = object [ t .= v | (k,v) <- [("0.2.0", "some notes") :: (Version, Text)], let (String t) = toJSON k ] hm = object [ t .= v | (k, v) <- [("0.2.0", "some notes") :: (Version, Text)], let (String t) = toJSON k ]
-- >>> encode rn -- >>> encode rn
-- "{\"0.2.0\":\"notes one\",\"0.3.0\":\"notes two\"}" -- "{\"0.2.0\":\"notes one\",\"0.3.0\":\"notes two\"}"

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

@@ -3,7 +3,7 @@
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
module Handler.Types.Status where module Handler.Types.Status where
import Startlude hiding (toLower) import Startlude hiding ( toLower )
import Data.Aeson import Data.Aeson
import Yesod.Core.Content import Yesod.Core.Content
@@ -51,7 +51,7 @@ data OSVersionRes = OSVersionRes
, osVersionVersion :: Version , osVersionVersion :: Version
} deriving (Eq, Show) } deriving (Eq, Show)
instance ToJSON OSVersionRes where instance ToJSON OSVersionRes where
toJSON OSVersionRes { .. } = object ["status" .= osVersionStatus, "version" .= osVersionVersion] toJSON OSVersionRes {..} = object ["status" .= osVersionStatus, "version" .= osVersionVersion]
instance ToContent OSVersionRes where instance ToContent OSVersionRes where
toContent = toContent . toJSON toContent = toContent . toJSON
instance ToTypedContent OSVersionRes where instance ToTypedContent OSVersionRes where

6
src/Handler/Version.hs
View File

@@ -6,7 +6,7 @@
module Handler.Version where module Handler.Version where
import Startlude hiding (Handler) import Startlude hiding ( Handler )
import Control.Monad.Trans.Maybe import Control.Monad.Trans.Maybe
import Yesod.Core import Yesod.Core
@@ -28,10 +28,10 @@ getVersionR = do
getVersionAppR :: Text -> Handler (Maybe AppVersionRes) getVersionAppR :: Text -> Handler (Maybe AppVersionRes)
getVersionAppR appId = do getVersionAppR appId = do
(appsDir, appMgrDir) <- getsYesod $ ((</> "apps") . resourcesDir &&& staticBinDir) . appSettings (appsDir, appMgrDir) <- getsYesod $ ((</> "apps") . resourcesDir &&& staticBinDir) . appSettings
res <- getVersionWSpec appsDir appExt res <- getVersionWSpec appsDir appExt
case res of case res of
Nothing -> pure res Nothing -> pure res
Just r -> do Just r -> do
let appDir = (<> "/") . (</> (show $ appVersionVersion r)) . (</> toS appId) $ appsDir let appDir = (<> "/") . (</> (show $ appVersionVersion r)) . (</> toS appId) $ appsDir
addPackageHeader appMgrDir appDir appExt addPackageHeader appMgrDir appDir appExt
pure res pure res

6
src/Lib/Error.hs
View File

@@ -21,7 +21,7 @@ instance Exception S9Error
-- | Redact any sensitive data in this function -- | Redact any sensitive data in this function
toError :: S9Error -> Error toError :: S9Error -> Error
toError = \case toError = \case
PersistentE t -> Error DATABASE_ERROR t PersistentE t -> Error DATABASE_ERROR t
AppMgrE cmd code -> Error APPMGR_ERROR [i|"appmgr #{cmd}" exited with #{code}|] AppMgrE cmd code -> Error APPMGR_ERROR [i|"appmgr #{cmd}" exited with #{code}|]
data ErrorCode = data ErrorCode =
@@ -51,8 +51,8 @@ instance ToContent S9Error where
toStatus :: S9Error -> Status toStatus :: S9Error -> Status
toStatus = \case toStatus = \case
PersistentE _ -> status500 PersistentE _ -> status500
AppMgrE _ _ -> status500 AppMgrE _ _ -> status500
handleS9ErrT :: MonadHandler m => S9ErrT m a -> m a handleS9ErrT :: MonadHandler m => S9ErrT m a -> m a

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

@@ -44,42 +44,44 @@ readProcessInheritStderr a b c = liftIO $ do
getConfig :: (MonadIO m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> S9ErrT m Text getConfig :: (MonadIO m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> S9ErrT m Text
getConfig appmgrPath appPath e@(Extension appId) = fmap decodeUtf8 $ do getConfig appmgrPath appPath e@(Extension appId) = fmap decodeUtf8 $ do
(ec, out) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "config", appPath <> show e, "--json"] "" (ec, out) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk")
["inspect", "config", appPath <> show e, "--json"]
""
case ec of case ec of
ExitSuccess -> pure out ExitSuccess -> pure out
ExitFailure n -> throwE $ AppMgrE [i|info config #{appId} \--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 :: (MonadIO m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> S9ErrT m ByteString
getManifest appmgrPath appPath e@(Extension appId) = do getManifest appmgrPath appPath e@(Extension appId) = do
(ec, bs) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "manifest", appPath <> show e] "" (ec, bs) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "manifest", appPath <> show e] ""
case ec of case ec of
ExitSuccess -> pure bs ExitSuccess -> pure bs
ExitFailure n -> throwE $ AppMgrE [i|embassy-sdk inspect manifest #{appId}|] n ExitFailure n -> throwE $ AppMgrE [i|embassy-sdk inspect manifest #{appId}|] n
getIcon :: (MonadIO m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> S9ErrT m ByteString getIcon :: (MonadIO m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> S9ErrT m ByteString
getIcon appmgrPath appPath e@(Extension icon) = do getIcon appmgrPath appPath e@(Extension icon) = do
(ec, bs) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "icon", appPath] "" (ec, bs) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "icon", appPath] ""
case ec of case ec of
ExitSuccess -> pure bs ExitSuccess -> pure bs
ExitFailure n -> throwE $ AppMgrE [i|embassy-sdk inspect icon #{icon}|] n ExitFailure n -> throwE $ AppMgrE [i|embassy-sdk inspect icon #{icon}|] n
getPackageHash :: (MonadIO m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> S9ErrT m ByteString getPackageHash :: (MonadIO m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> S9ErrT m ByteString
getPackageHash appmgrPath appPath e@(Extension appId) = do getPackageHash appmgrPath appPath e@(Extension appId) = do
(ec, bs) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "hash", appPath <> show e] "" (ec, bs) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "hash", appPath <> show e] ""
case ec of case ec of
ExitSuccess -> pure bs ExitSuccess -> pure bs
ExitFailure n -> throwE $ AppMgrE [i|embassy-sdk inspect hash #{appId}|] n ExitFailure n -> throwE $ AppMgrE [i|embassy-sdk inspect hash #{appId}|] n
getInstructions :: (MonadIO m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> S9ErrT m ByteString getInstructions :: (MonadIO m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> S9ErrT m ByteString
getInstructions appmgrPath appPath e@(Extension appId) = do getInstructions appmgrPath appPath e@(Extension appId) = do
(ec, bs) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "instructions", appPath] "" (ec, bs) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "instructions", appPath] ""
case ec of case ec of
ExitSuccess -> pure bs ExitSuccess -> pure bs
ExitFailure n -> throwE $ AppMgrE [i|embassy-sdk inspect instructions #{appId}|] n ExitFailure n -> throwE $ AppMgrE [i|embassy-sdk inspect instructions #{appId}|] n
getLicense :: (MonadIO m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> S9ErrT m ByteString getLicense :: (MonadIO m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> S9ErrT m ByteString
getLicense appmgrPath appPath e@(Extension appId) = do getLicense appmgrPath appPath e@(Extension appId) = do
(ec, bs) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "license", appPath] "" (ec, bs) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "license", appPath] ""
case ec of case ec of
ExitSuccess -> pure bs ExitSuccess -> pure bs
ExitFailure n -> throwE $ AppMgrE [i|embassy-sdk inspect license #{appId}|] n ExitFailure n -> throwE $ AppMgrE [i|embassy-sdk inspect license #{appId}|] n

4
src/Lib/SystemCtl.hs
View File

@@ -1,7 +1,7 @@
module Lib.SystemCtl where module Lib.SystemCtl where
import Startlude hiding (words) import Startlude hiding ( words )
import Protolude.Unsafe import Protolude.Unsafe
import Data.String import Data.String
import System.Process import System.Process

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

@@ -18,10 +18,10 @@ import Lib.Types.Emver
import Orphans.Emver ( ) import Orphans.Emver ( )
import System.Directory import System.Directory
import Lib.Registry import Lib.Registry
import Model import Model
import qualified Data.Text as T import qualified Data.Text as T
import Data.String.Interpolate.IsString import Data.String.Interpolate.IsString
import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy as BS
type AppIdentifier = Text type AppIdentifier = Text
@@ -37,14 +37,15 @@ data VersionInfo = VersionInfo
mapSVersionToVersionInfo :: [SVersion] -> [VersionInfo] mapSVersionToVersionInfo :: [SVersion] -> [VersionInfo]
mapSVersionToVersionInfo sv = do mapSVersionToVersionInfo sv = do
(\v -> VersionInfo { (\v -> VersionInfo { versionInfoVersion = sVersionNumber v
versionInfoVersion = sVersionNumber v , versionInfoReleaseNotes = sVersionReleaseNotes v
, versionInfoReleaseNotes = sVersionReleaseNotes v , versionInfoDependencies = HM.empty
, versionInfoDependencies = HM.empty , versionInfoOsRequired = sVersionOsVersionRequired v
, versionInfoOsRequired = sVersionOsVersionRequired v , versionInfoOsRecommended = sVersionOsVersionRecommended v
, versionInfoOsRecommended = sVersionOsVersionRecommended v , versionInfoInstallAlert = Nothing
, versionInfoInstallAlert = Nothing }
}) <$> sv )
<$> sv
instance Ord VersionInfo where instance Ord VersionInfo where
compare = compare `on` versionInfoVersion compare = compare `on` versionInfoVersion
@@ -102,7 +103,7 @@ instance FromJSON AppManifest where
storeAppVersionInfo <- config .: "version-info" >>= \case storeAppVersionInfo <- config .: "version-info" >>= \case
[] -> fail "No Valid Version Info" [] -> fail "No Valid Version Info"
(x : xs) -> pure $ x :| xs (x : xs) -> pure $ x :| xs
storeAppTimestamp <- config .:? "timestamp" storeAppTimestamp <- config .:? "timestamp"
pure (appId, StoreApp { .. }) pure (appId, StoreApp { .. })
return $ AppManifest (HM.fromList apps) return $ AppManifest (HM.fromList apps)
instance ToJSON AppManifest where instance ToJSON AppManifest where
@@ -121,10 +122,10 @@ filterOsRecommended av sa = case NE.filter ((av <||) . versionInfoOsRecommended)
addFileTimestamp :: KnownSymbol a => FilePath -> Extension a -> StoreApp -> Version -> IO (Maybe StoreApp) addFileTimestamp :: KnownSymbol a => FilePath -> Extension a -> StoreApp -> Version -> IO (Maybe StoreApp)
addFileTimestamp appDir ext service v = do addFileTimestamp appDir ext service v = do
getVersionedFileFromDir appDir ext v >>= \case getVersionedFileFromDir appDir ext v >>= \case
Nothing -> pure Nothing Nothing -> pure Nothing
Just file -> do Just file -> do
time <- getModificationTime file time <- getModificationTime file
pure $ Just service {storeAppTimestamp = Just time } pure $ Just service { storeAppTimestamp = Just time }
data ServiceDependencyInfo = ServiceDependencyInfo data ServiceDependencyInfo = ServiceDependencyInfo
{ serviceDependencyInfoOptional :: Maybe Text { serviceDependencyInfoOptional :: Maybe Text
@@ -134,10 +135,10 @@ data ServiceDependencyInfo = ServiceDependencyInfo
} deriving (Show) } deriving (Show)
instance FromJSON ServiceDependencyInfo where instance FromJSON ServiceDependencyInfo where
parseJSON = withObject "service dependency info" $ \o -> do parseJSON = withObject "service dependency info" $ \o -> do
serviceDependencyInfoOptional <- o .:? "optional" serviceDependencyInfoOptional <- o .:? "optional"
serviceDependencyInfoVersion <- o .: "version" serviceDependencyInfoVersion <- o .: "version"
serviceDependencyInfoDescription <- o .:? "description" serviceDependencyInfoDescription <- o .:? "description"
serviceDependencyInfoCritical <- o .: "critical" serviceDependencyInfoCritical <- o .: "critical"
pure ServiceDependencyInfo { .. } pure ServiceDependencyInfo { .. }
instance ToJSON ServiceDependencyInfo where instance ToJSON ServiceDependencyInfo where
toJSON ServiceDependencyInfo {..} = object toJSON ServiceDependencyInfo {..} = object
@@ -173,18 +174,18 @@ data ServiceManifest = ServiceManifest
} deriving (Show) } deriving (Show)
instance FromJSON ServiceManifest where instance FromJSON ServiceManifest where
parseJSON = withObject "service manifest" $ \o -> do parseJSON = withObject "service manifest" $ \o -> do
serviceManifestId <- o .: "id" serviceManifestId <- o .: "id"
serviceManifestTitle <- o .: "title" serviceManifestTitle <- o .: "title"
serviceManifestVersion <- o .: "version" serviceManifestVersion <- o .: "version"
serviceManifestDescriptionLong <- o .: "description" >>= (.: "long") serviceManifestDescriptionLong <- o .: "description" >>= (.: "long")
serviceManifestDescriptionShort <- o .: "description" >>= (.: "short") serviceManifestDescriptionShort <- o .: "description" >>= (.: "short")
serviceManifestIcon <- o .: "assets" >>= (.: "icon") serviceManifestIcon <- o .: "assets" >>= (.: "icon")
serviceManifestReleaseNotes <- o .: "release-notes" serviceManifestReleaseNotes <- o .: "release-notes"
alerts <- o .: "alerts" alerts <- o .: "alerts"
a <- for (HM.toList alerts) $ \(key, value) -> do a <- for (HM.toList alerts) $ \(key, value) -> do
alertType <- case readMaybe $ T.toUpper key of alertType <- case readMaybe $ T.toUpper key of
Nothing -> fail "could not parse alert key as ServiceAlert" Nothing -> fail "could not parse alert key as ServiceAlert"
Just t -> pure t Just t -> pure t
alertDesc <- parseJSON value alertDesc <- parseJSON value
pure (alertType, alertDesc) pure (alertType, alertDesc)
let serviceManifestAlerts = HM.fromList a let serviceManifestAlerts = HM.fromList a
@@ -197,7 +198,7 @@ instance ToJSON ServiceManifest where
, "version" .= serviceManifestVersion , "version" .= serviceManifestVersion
, "description" .= object ["short" .= serviceManifestDescriptionShort, "long" .= serviceManifestDescriptionLong] , "description" .= object ["short" .= serviceManifestDescriptionShort, "long" .= serviceManifestDescriptionLong]
, "release-notes" .= serviceManifestReleaseNotes , "release-notes" .= serviceManifestReleaseNotes
, "alerts" .= object [ t .= v | (k,v) <- HM.toList serviceManifestAlerts, let (String t) = toJSON k ] , "alerts" .= object [ t .= v | (k, v) <- HM.toList serviceManifestAlerts, let (String t) = toJSON k ]
, "dependencies" .= serviceManifestDependencies , "dependencies" .= serviceManifestDependencies
] ]

40
src/Lib/Types/Category.hs
View File

@@ -3,11 +3,11 @@
module Lib.Types.Category where module Lib.Types.Category where
import Startlude import Startlude
import Database.Persist.Postgresql import Database.Persist.Postgresql
import Data.Aeson import Data.Aeson
import Control.Monad import Control.Monad
import Yesod.Core import Yesod.Core
data CategoryTitle = FEATURED data CategoryTitle = FEATURED
| BITCOIN | BITCOIN
@@ -19,29 +19,29 @@ data CategoryTitle = FEATURED
deriving (Eq, Enum, Show, Read) deriving (Eq, Enum, Show, Read)
instance PersistField CategoryTitle where instance PersistField CategoryTitle where
fromPersistValue = fromPersistValueJSON fromPersistValue = fromPersistValueJSON
toPersistValue = toPersistValueJSON toPersistValue = toPersistValueJSON
instance PersistFieldSql CategoryTitle where instance PersistFieldSql CategoryTitle where
sqlType _ = SqlString sqlType _ = SqlString
instance ToJSON CategoryTitle where instance ToJSON CategoryTitle where
-- toJSON = String . T.toLower . show -- toJSON = String . T.toLower . show
toJSON = \case toJSON = \case
FEATURED -> "featured" FEATURED -> "featured"
BITCOIN -> "bitcoin" BITCOIN -> "bitcoin"
LIGHTNING -> "lightning" LIGHTNING -> "lightning"
DATA -> "data" DATA -> "data"
MESSAGING -> "messaging" MESSAGING -> "messaging"
SOCIAL -> "social" SOCIAL -> "social"
ALTCOIN -> "alt coin" ALTCOIN -> "alt coin"
instance FromJSON CategoryTitle where instance FromJSON CategoryTitle where
parseJSON = withText "CategoryTitle" $ \case parseJSON = withText "CategoryTitle" $ \case
"featured" -> pure FEATURED "featured" -> pure FEATURED
"bitcoin" -> pure BITCOIN "bitcoin" -> pure BITCOIN
"lightning" -> pure LIGHTNING "lightning" -> pure LIGHTNING
"data" -> pure DATA "data" -> pure DATA
"messaging" -> pure MESSAGING "messaging" -> pure MESSAGING
"social" -> pure SOCIAL "social" -> pure SOCIAL
"alt coin" -> pure ALTCOIN "alt coin" -> pure ALTCOIN
_ -> fail "unknown category title" _ -> fail "unknown category title"
instance ToContent CategoryTitle where instance ToContent CategoryTitle where
toContent = toContent . toJSON toContent = toContent . toJSON
instance ToTypedContent CategoryTitle where instance ToTypedContent CategoryTitle where

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

@@ -48,8 +48,8 @@ import Control.Applicative ( liftA2
) )
import Data.String ( IsString(..) ) import Data.String ( IsString(..) )
import qualified Data.Text as T import qualified Data.Text as T
import Data.Aeson import Data.Aeson
import Startlude (Hashable) import Startlude ( Hashable )
-- | AppVersion is the core representation of the SemverQuad type. -- | AppVersion is the core representation of the SemverQuad type.
newtype Version = Version { unVersion :: (Word, Word, Word, Word) } deriving (Eq, Ord, ToJSONKey, Hashable) newtype Version = Version { unVersion :: (Word, Word, Word, Word) } deriving (Eq, Ord, ToJSONKey, Hashable)

6
src/Startlude.hs
View File

@@ -1,7 +1,7 @@
module Startlude module Startlude
( module X ( module X
, module Startlude , module Startlude
) )
where where
import Control.Arrow as X import Control.Arrow as X

12
src/Util/Function.hs
View File

@@ -13,11 +13,11 @@ preimage f target = filter ((== target) . f)
mapFind :: ([a] -> Maybe a) -> (b -> a) -> [b] -> Maybe b mapFind :: ([a] -> Maybe a) -> (b -> a) -> [b] -> Maybe b
mapFind _ _ [] = Nothing mapFind _ _ [] = Nothing
mapFind finder mapping (b:bs) = let mapFind finder mapping (b : bs) =
mB = mapFind finder mapping bs let mB = mapFind finder mapping bs
mA = finder [mapping b] mA = finder [mapping b]
in case (mB, mA) of in case (mB, mA) of
(Just b',_) -> Just b' (Just b', _ ) -> Just b'
(Nothing, Just _) -> Just b (Nothing, Just _) -> Just b
_ -> Nothing _ -> Nothing

12
src/Util/Shared.hs
View File

@@ -2,7 +2,7 @@
module Util.Shared where module Util.Shared where
import Startlude hiding (Handler) import Startlude hiding ( Handler )
import qualified Data.Text as T import qualified Data.Text as T
import Network.HTTP.Types import Network.HTTP.Types
@@ -12,8 +12,8 @@ import Foundation
import Lib.Registry import Lib.Registry
import Lib.Types.Emver import Lib.Types.Emver
import Data.Semigroup import Data.Semigroup
import Lib.External.AppMgr import Lib.External.AppMgr
import Lib.Error import Lib.Error
getVersionFromQuery :: KnownSymbol a => FilePath -> Extension a -> Handler (Maybe Version) getVersionFromQuery :: KnownSymbol a => FilePath -> Extension a -> Handler (Maybe Version)
getVersionFromQuery rootDir ext = do getVersionFromQuery rootDir ext = do
@@ -23,7 +23,11 @@ getVersionFromQuery rootDir ext = do
Just t -> pure t Just t -> pure t
getBestVersion rootDir ext spec getBestVersion rootDir ext spec
getBestVersion :: (MonadIO m, KnownSymbol a, MonadLogger m) => FilePath -> Extension a -> VersionRange -> m (Maybe Version) getBestVersion :: (MonadIO m, KnownSymbol a, MonadLogger m)
=> FilePath
-> Extension a
-> VersionRange
-> m (Maybe Version)
getBestVersion rootDir ext spec = do getBestVersion rootDir ext spec = do
-- @TODO change to db query? -- @TODO change to db query?
appVersions <- liftIO $ getAvailableAppVersions rootDir ext appVersions <- liftIO $ getAvailableAppVersions rootDir ext

147
test/Handler/AppSpec.hs
View File

@@ -1,82 +1,81 @@
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
module Handler.AppSpec (spec) where module Handler.AppSpec
( spec
)
where
import Startlude import Startlude
import Database.Persist.Sql import Database.Persist.Sql
import Data.Maybe import Data.Maybe
import TestImport import TestImport
import Model import Model
spec :: Spec spec :: Spec
spec = do spec = do
describe "GET /apps" $ describe "GET /apps" $ withApp $ it "returns list of apps" $ do
withApp $ it "returns list of apps" $ do request $ do
request $ do setMethod "GET"
setMethod "GET" setUrl ("/apps" :: Text)
setUrl ("/apps" :: Text) bodyContains "bitcoind"
bodyContains "bitcoind" bodyContains "version: 0.18.1"
bodyContains "version: 0.18.1" statusIs 200
statusIs 200 describe "GET /apps/:appId with unknown version spec for bitcoin" $ withApp $ it "fails to get unknown app" $ do
describe "GET /apps/:appId with unknown version spec for bitcoin" $ request $ do
withApp $ it "fails to get unknown app" $ do setMethod "GET"
request $ do setUrl ("/apps/bitcoind.s9pk?spec=0.18.3" :: Text)
setMethod "GET" statusIs 404
setUrl ("/apps/bitcoind.s9pk?spec=0.18.3" :: Text) describe "GET /apps/:appId with unknown app" $ withApp $ it "fails to get an unregistered app" $ do
statusIs 404 request $ do
describe "GET /apps/:appId with unknown app" $ setMethod "GET"
withApp $ it "fails to get an unregistered app" $ do setUrl ("/apps/tempapp.s9pk?spec=0.0.1" :: Text)
request $ do statusIs 404
setMethod "GET" describe "GET /apps/:appId with existing version spec for bitcoin"
setUrl ("/apps/tempapp.s9pk?spec=0.0.1" :: Text) $ withApp
statusIs 404 $ it "creates app and metric records"
describe "GET /apps/:appId with existing version spec for bitcoin" $ $ do
withApp $ it "creates app and metric records" $ do request $ do
request $ do setMethod "GET"
setMethod "GET" setUrl ("/apps/bitcoind.s9pk?spec==0.18.1" :: Text)
setUrl ("/apps/bitcoind.s9pk?spec==0.18.1" :: Text) statusIs 200
statusIs 200 apps <- runDBtest $ selectList [SAppAppId ==. "bitcoind"] []
apps <- runDBtest $ selectList [SAppAppId ==. "bitcoind"] [] assertEq "app should exist" (length apps) 1
assertEq "app should exist" (length apps) 1 let app = fromJust $ head apps
let app = fromJust $ head apps metrics <- runDBtest $ selectList [MetricAppId ==. entityKey app] []
metrics <- runDBtest $ selectList [MetricAppId ==. entityKey app] [] assertEq "metric should exist" (length metrics) 1
assertEq "metric should exist" (length metrics) 1 describe "GET /apps/:appId with existing version spec for cups" $ withApp $ it "creates app and metric records" $ do
describe "GET /apps/:appId with existing version spec for cups" $ request $ do
withApp $ it "creates app and metric records" $ do setMethod "GET"
request $ do setUrl ("/apps/cups.s9pk?spec=0.2.1" :: Text)
setMethod "GET" statusIs 200
setUrl ("/apps/cups.s9pk?spec=0.2.1" :: Text) apps <- runDBtest $ selectList [SAppAppId ==. "cups"] []
statusIs 200 assertEq "app should exist" (length apps) 1
apps <- runDBtest $ selectList [SAppAppId ==. "cups"] [] let app = fromJust $ head apps
assertEq "app should exist" (length apps) 1 metrics <- runDBtest $ selectList [MetricAppId ==. entityKey app] []
let app = fromJust $ head apps assertEq "metric should exist" (length metrics) 1
metrics <- runDBtest $ selectList [MetricAppId ==. entityKey app] [] version <- runDBtest $ selectList [SVersionAppId ==. entityKey app] []
assertEq "metric should exist" (length metrics) 1 assertEq "version should exist" (length version) 1
version <- runDBtest $ selectList [SVersionAppId ==. entityKey app] [] describe "GET /sys/proxy.pac" $ withApp $ it "does not record metric but request successful" $ do
assertEq "version should exist" (length version) 1 request $ do
describe "GET /sys/proxy.pac" $ setMethod "GET"
withApp $ it "does not record metric but request successful" $ do setUrl ("/sys/proxy.pac?spec=0.1.0" :: Text)
request $ do statusIs 200
setMethod "GET" -- select * from s_app
setUrl ("/sys/proxy.pac?spec=0.1.0" :: Text) apps <- runDBtest $ selectList ([] :: [Filter SApp]) []
statusIs 200 assertEq "no apps should exist" (length apps) 0
-- select * from s_app describe "GET /sys/:sysId" $ withApp $ it "does not record metric but request successful" $ do
apps <- runDBtest $ selectList ([] :: [Filter SApp])[] request $ do
assertEq "no apps should exist" (length apps) 0 setMethod "GET"
describe "GET /sys/:sysId" $ setUrl ("/sys/agent?spec=0.0.0" :: Text)
withApp $ it "does not record metric but request successful" $ do statusIs 200
request $ do apps <- runDBtest $ selectList ([] :: [Filter SApp]) []
setMethod "GET" assertEq "no apps should exist" (length apps) 0
setUrl ("/sys/agent?spec=0.0.0" :: Text)
statusIs 200
apps <- runDBtest $ selectList ([] :: [Filter SApp])[]
assertEq "no apps should exist" (length apps) 0
-- @TODO uncomment when new portable appmgr live -- @TODO uncomment when new portable appmgr live
xdescribe "GET /apps/manifest/#S9PK" $ xdescribe "GET /apps/manifest/#S9PK" $ withApp $ it "gets bitcoin manifest" $ do
withApp $ it "gets bitcoin manifest" $ do request $ do
request $ do setMethod "GET"
setMethod "GET" setUrl ("/apps/manifest/bitcoind?spec==0.20.1" :: Text)
setUrl ("/apps/manifest/bitcoind?spec==0.20.1" :: Text) statusIs 200
statusIs 200 bodyContains
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\":{}}" "{\"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\":{}}"

188
test/Handler/MarketplaceSpec.hs
View File

@@ -1,79 +1,129 @@
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
module Handler.MarketplaceSpec (spec) where module Handler.MarketplaceSpec
( spec
)
where
import Startlude hiding (Any) import Startlude hiding ( Any )
import Database.Persist.Sql import Database.Persist.Sql
import Data.Maybe import Data.Maybe
import TestImport import TestImport
import Model import Model
import Database.Marketplace import Database.Marketplace
import Lib.Types.Category import Lib.Types.Category
import Lib.Types.Emver import Lib.Types.Emver
spec :: Spec spec :: Spec
spec = do spec = do
describe "searchServices with category" $ describe "searchServices with category" $ withApp $ it "should filter services with featured category" $ do
withApp $ it "should filter services with featured category" $ do time <- liftIO getCurrentTime
time <- liftIO getCurrentTime btc <- runDBtest $ insert $ SApp time
btc <- runDBtest $ insert $ SApp time (Just time) "Bitcoin Core" "bitcoind" "short desc bitcoin" "long desc bitcoin" "png" (Just time)
lnd <- runDBtest $ insert $ SApp time (Just time) "Lightning Network Daemon" "lnd" "short desc lnd" "long desc lnd" "png" "Bitcoin Core"
featuredCat <- runDBtest $ insert $ Category time FEATURED Nothing "desc" "bitcoind"
btcCat <- runDBtest $ insert $ Category time BITCOIN Nothing "desc" "short desc bitcoin"
lnCat <- runDBtest $ insert $ Category time LIGHTNING Nothing "desc" "long desc bitcoin"
_ <- runDBtest $ insert_ $ ServiceCategory time btc featuredCat "bitcoin" FEATURED Nothing "png"
_ <- runDBtest $ insert_ $ ServiceCategory time lnd lnCat "lnd" LIGHTNING Nothing lnd <- runDBtest $ insert $ SApp time
_ <- runDBtest $ insert_ $ ServiceCategory time lnd btcCat "lnd" BITCOIN Nothing (Just time)
_ <- runDBtest $ insert_ $ ServiceCategory time btc btcCat "bitcon" BITCOIN Nothing "Lightning Network Daemon"
apps <- runDBtest $ searchServices FEATURED 20 0 "" "lnd"
assertEq "should exist" (length apps) 1 "short desc lnd"
let app' = fromJust $ head apps "long desc lnd"
assertEq "should be bitcoin" (sAppTitle $ entityVal app') "Bitcoin Core" "png"
describe "searchServices with category" $ featuredCat <- runDBtest $ insert $ Category time FEATURED Nothing "desc"
withApp $ it "should filter services with bitcoin category" $ do btcCat <- runDBtest $ insert $ Category time BITCOIN Nothing "desc"
time <- liftIO getCurrentTime lnCat <- runDBtest $ insert $ Category time LIGHTNING Nothing "desc"
btc <- runDBtest $ insert $ SApp time (Just time) "Bitcoin Core" "bitcoind" "short desc bitcoin" "long desc bitcoin" "png" _ <- runDBtest $ insert_ $ ServiceCategory time btc featuredCat "bitcoin" FEATURED Nothing
lnd <- runDBtest $ insert $ SApp time (Just time) "Lightning Network Daemon" "lnd" "short desc lnd" "long desc lnd" "png" _ <- runDBtest $ insert_ $ ServiceCategory time lnd lnCat "lnd" LIGHTNING Nothing
featuredCat <- runDBtest $ insert $ Category time FEATURED Nothing "desc" _ <- runDBtest $ insert_ $ ServiceCategory time lnd btcCat "lnd" BITCOIN Nothing
btcCat <- runDBtest $ insert $ Category time BITCOIN Nothing "desc" _ <- runDBtest $ insert_ $ ServiceCategory time btc btcCat "bitcon" BITCOIN Nothing
lnCat <- runDBtest $ insert $ Category time LIGHTNING Nothing "desc" apps <- runDBtest $ searchServices FEATURED 20 0 ""
_ <- runDBtest $ insert_ $ ServiceCategory time btc featuredCat "bitcoin" FEATURED Nothing assertEq "should exist" (length apps) 1
_ <- runDBtest $ insert_ $ ServiceCategory time lnd lnCat "lnd" LIGHTNING Nothing let app' = fromJust $ head apps
_ <- runDBtest $ insert_ $ ServiceCategory time lnd btcCat "lnd" BITCOIN Nothing assertEq "should be bitcoin" (sAppTitle $ entityVal app') "Bitcoin Core"
_ <- runDBtest $ insert_ $ ServiceCategory time btc btcCat "bitcon" BITCOIN Nothing describe "searchServices with category" $ withApp $ it "should filter services with bitcoin category" $ do
apps <- runDBtest $ searchServices BITCOIN 20 0 "" time <- liftIO getCurrentTime
assertEq "should exist" (length apps) 2 btc <- runDBtest $ insert $ SApp time
describe "searchServices with fuzzy query" $ (Just time)
withApp $ it "runs search service with fuzzy text in long description" $ do "Bitcoin Core"
time <- liftIO getCurrentTime "bitcoind"
app1 <- runDBtest $ insert $ SApp time (Just time) "Bitcoin Core" "bitcoind" "short desc" "long desc" "png" "short desc bitcoin"
app2 <- runDBtest $ insert $ SApp time (Just time) "Lightning Network Daemon" "lnd" "short desc" "lightning long desc" "png" "long desc bitcoin"
cate <- runDBtest $ insert $ Category time FEATURED Nothing "desc" "png"
_ <- runDBtest $ insert_ $ ServiceCategory time app1 cate "bitcoind" FEATURED Nothing lnd <- runDBtest $ insert $ SApp time
_ <- runDBtest $ insert_ $ ServiceCategory time app2 cate "lnd" FEATURED Nothing (Just time)
apps <- runDBtest $ searchServices FEATURED 20 0 "lightning" "Lightning Network Daemon"
assertEq "should exist" (length apps) 1 "lnd"
let app' = fromJust $ head apps "short desc lnd"
print app' "long desc lnd"
describe "searchServices with any category" $ "png"
withApp $ it "runs search service for any category" $ do featuredCat <- runDBtest $ insert $ Category time FEATURED Nothing "desc"
time <- liftIO getCurrentTime btcCat <- runDBtest $ insert $ Category time BITCOIN Nothing "desc"
btc <- runDBtest $ insert $ SApp time (Just time) "Bitcoin Core" "bitcoind" "short desc bitcoin" "long desc bitcoin" "png" lnCat <- runDBtest $ insert $ Category time LIGHTNING Nothing "desc"
_ <- runDBtest $ insert $ SVersion time (Just time)btc "0.19.0" "notes" Any Any _ <- runDBtest $ insert_ $ ServiceCategory time btc featuredCat "bitcoin" FEATURED Nothing
_ <- runDBtest $ insert $ SVersion time (Just time)btc "0.20.0" "notes" Any Any _ <- runDBtest $ insert_ $ ServiceCategory time lnd lnCat "lnd" LIGHTNING Nothing
lnd <- runDBtest $ insert $ SApp time (Just time) "Lightning Network Daemon" "lnd" "short desc lnd" "long desc lnd" "png" _ <- runDBtest $ insert_ $ ServiceCategory time lnd btcCat "lnd" BITCOIN Nothing
_ <- runDBtest $ insert $ SVersion time (Just time)lnd "0.18.0" "notes" Any Any _ <- runDBtest $ insert_ $ ServiceCategory time btc btcCat "bitcon" BITCOIN Nothing
_ <- runDBtest $ insert $ SVersion time (Just time)lnd "0.17.0" "notes" Any Any apps <- runDBtest $ searchServices BITCOIN 20 0 ""
featuredCat <- runDBtest $ insert $ Category time FEATURED Nothing "desc" assertEq "should exist" (length apps) 2
btcCat <- runDBtest $ insert $ Category time BITCOIN Nothing "desc" describe "searchServices with fuzzy query"
lnCat <- runDBtest $ insert $ Category time LIGHTNING Nothing "desc" $ withApp
_ <- runDBtest $ insert_ $ ServiceCategory time btc featuredCat "bitcoin" FEATURED Nothing $ it "runs search service with fuzzy text in long description"
_ <- runDBtest $ insert_ $ ServiceCategory time lnd lnCat "lnd" LIGHTNING Nothing $ do
_ <- runDBtest $ insert_ $ ServiceCategory time lnd btcCat "lnd" BITCOIN Nothing time <- liftIO getCurrentTime
_ <- runDBtest $ insert_ $ ServiceCategory time btc btcCat "bitcon" BITCOIN Nothing app1 <- runDBtest $ insert $ SApp time
apps <- runDBtest $ searchServices ANY 20 0 "" (Just time)
assertEq "should exist" (length apps) 2 "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" $ -- describe "getServiceVersionsWithReleaseNotes" $
-- withApp $ it "gets service with mapping of version to release notes" $ do -- withApp $ it "gets service with mapping of version to release notes" $ do
-- time <- liftIO getCurrentTime -- time <- liftIO getCurrentTime

8
test/Main.hs
View File

@@ -1,10 +1,10 @@
module Main where module Main where
import Test.Hspec.Runner import Test.Hspec.Runner
import qualified Spec import qualified Spec
import Test.Hspec.Formatters import Test.Hspec.Formatters
import Startlude import Startlude
import GHC.IO.Encoding import GHC.IO.Encoding
main :: IO () main :: IO ()

6
test/TestImport.hs
View File

@@ -8,7 +8,7 @@ module TestImport
) )
where where
import Startlude hiding (Handler) import Startlude hiding ( Handler )
import Application ( makeFoundation import Application ( makeFoundation
, makeLogWare , makeLogWare
) )
@@ -23,8 +23,8 @@ import Database.Persist.Sql
import Text.Shakespeare.Text ( st ) import Text.Shakespeare.Text ( st )
import Yesod.Core import Yesod.Core
import qualified Data.Text as T import qualified Data.Text as T
import Database.Esqueleto.Internal.Internal import Database.Esqueleto.Internal.Internal
import Database.Persist.Sql.Types.Internal import Database.Persist.Sql.Types.Internal
runHandler :: Handler a -> YesodExample RegistryCtx a runHandler :: Handler a -> YesodExample RegistryCtx a
runHandler handler = do runHandler handler = do