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 36a9f3f6f2
commit d3c4772b05
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
import Prelude
import Application (getApplicationRepl, shutdownApp)
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
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.
@@ -55,36 +57,35 @@ 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
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
-- 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)
-- | 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 ()
@@ -92,10 +93,10 @@ 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"
Nothing -> putStrLn "no Yesod app running"
Just tidStore -> do
withStore tidStore $ readIORef >=> killThread
putStrLn "Yesod app is shutdown"
tidStoreNum :: Word32
tidStoreNum = 1

6
app/devel.hs
View File

@@ -1,6 +1,6 @@
{-# LANGUAGE PackageImports #-}
import "start9-registry" Application (develMain)
import Prelude (IO)
import "start9-registry" Application ( develMain )
import Prelude ( 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
main :: IO ()

60
src/Database/Marketplace.hs
View File

@@ -4,45 +4,53 @@
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
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 => 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
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
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 (Just category) pageItems offset' query = select $ do
services <- from
(do
(service :& sc) <-
from $ table @SApp
from
$ table @SApp
`innerJoin` table @ServiceCategory
`on` (\(s :& sc) ->
sc ^. ServiceCategoryServiceId ==. s ^. SAppId)
`on` (\(s :& sc) -> sc ^. ServiceCategoryServiceId ==. s ^. SAppId)
-- if there is a cateogry, only search in category
-- weight title, short, long (bitcoin should equal Bitcoin Core)
where_ $ sc ^. ServiceCategoryCategoryName ==. val category
&&. ((service ^. SAppDescShort `ilike` (%) ++. val query ++. (%))
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) ]
orderBy [desc (services ^. SAppUpdatedAt)]
limit pageItems
offset offset'
pure services
@@ -51,8 +59,8 @@ newtype VersionsWithReleaseNotes = VersionsWithReleaseNotes (HashMap Version Tex
instance FromJSON VersionsWithReleaseNotes
instance PersistField VersionsWithReleaseNotes where
fromPersistValue = fromPersistValueJSON
toPersistValue = PersistText . show
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]
-- 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]

8
src/Handler/Apps.hs
View File

@@ -9,7 +9,7 @@
module Handler.Apps where
import Startlude hiding (Handler)
import Startlude hiding ( Handler )
import Control.Monad.Logger
import Data.Aeson
@@ -74,7 +74,7 @@ getSysR e = do
getAppManifestR :: AppIdentifier -> Handler TypedContent
getAppManifestR appId = do
(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)
Just v -> pure v
let appDir = (<> "/") . (</> show av) . (</> toS appId) $ appsDir
@@ -146,7 +146,7 @@ recordMetrics appId appVersion = do
case sa of
Nothing -> do
$logError $ appId' <> " not found in database"
notFound
notFound
Just a -> do
let appKey' = entityKey a
existingVersion <- runDB $ fetchAppVersion appVersion appKey'
@@ -155,4 +155,4 @@ recordMetrics appId appVersion = do
$logError $ "Version: " <> show appVersion <> " not found in database"
notFound
Just v -> runDB $ createMetric (entityKey a) (entityKey v)

14
src/Handler/Icons.hs
View File

@@ -36,7 +36,7 @@ ixt = toS $ toUpper <$> drop 1 ".png"
getIconsR :: AppIdentifier -> Handler TypedContent
getIconsR appId = do
(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)
Just v -> pure v
let appDir = (<> "/") . (</> show spec) . (</> toS appId) $ appsDir
@@ -57,10 +57,10 @@ getIconsR appId = do
$logInfo $ "unknown icon extension type: " <> show x <> ". Sending back typePlain."
pure typePlain
Just iconType -> case iconType of
PNG -> pure typePng
SVG -> pure typeSvg
JPG -> pure typeJpeg
JPEG -> pure typeJpeg
PNG -> pure typePng
SVG -> pure typeSvg
JPG -> pure typeJpeg
JPEG -> pure typeJpeg
respondSource mimeType (sendChunkBS =<< handleS9ErrT (getIcon appMgrDir (appDir </> show ext) ext))
-- (_, Just hout, _, _) <- liftIO (createProcess $ iconBs { std_out = CreatePipe })
-- respondSource typePlain (runConduit $ yieldMany () [iconBs])
@@ -70,7 +70,7 @@ getIconsR appId = do
getLicenseR :: AppIdentifier -> Handler TypedContent
getLicenseR appId = do
(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)
Just v -> pure v
servicePath <- liftIO $ getVersionedFileFromDir appsDir ext spec
@@ -83,7 +83,7 @@ getLicenseR appId = do
getInstructionsR :: AppIdentifier -> Handler TypedContent
getInstructionsR appId = do
(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)
Just v -> pure v
servicePath <- liftIO $ getVersionedFileFromDir appsDir ext spec

396
src/Handler/Marketplace.hs
View File

@@ -10,31 +10,35 @@
module Handler.Marketplace where
import Startlude hiding (from, Handler, on, sortOn)
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 Lib.Types.AppIndex
import qualified Data.HashMap.Strict as HM
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
import Util.Shared
import Startlude hiding ( from
, Handler
, on
, sortOn
)
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 Lib.Types.AppIndex
import qualified Data.HashMap.Strict as HM
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
import Util.Shared
newtype CategoryRes = CategoryRes {
categories :: [CategoryTitle]
@@ -58,7 +62,7 @@ data ServiceRes = ServiceRes
newtype ReleaseNotes = ReleaseNotes { unReleaseNotes :: HM.HashMap Version Text }
deriving (Eq, Show)
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
toContent = toContent . toJSON
instance ToTypedContent ReleaseNotes where
@@ -82,20 +86,15 @@ data DependencyInfo = DependencyInfo
, dependencyInfoIcon :: Text -- url
} deriving (Eq, Show)
instance ToJSON DependencyInfo where
toJSON DependencyInfo {..} = object
[ "icon" .= dependencyInfoIcon
, "title" .= dependencyInfoTitle
]
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
]
toJSON ServiceListRes {..} =
object ["categories" .= serviceListResCategories, "services" .= serviceListResServices]
instance ToContent ServiceListRes where
toContent = toContent . toJSON
instance ToTypedContent ServiceListRes where
@@ -109,7 +108,7 @@ data ServiceAvailable = ServiceAvailable
, serviceAvailableDescShort :: Text
} deriving (Show)
instance ToJSON ServiceAvailable where
toJSON ServiceAvailable { .. } = object
toJSON ServiceAvailable {..} = object
[ "id" .= serviceAvailableId
, "title" .= serviceAvailableTitle
, "version" .= serviceAvailableVersion
@@ -152,11 +151,8 @@ data EosRes = EosRes
, eosResReleaseNotes :: ReleaseNotes
} deriving (Eq, Show, Generic)
instance ToJSON EosRes where
toJSON EosRes { .. } = object
[ "version" .= eosResVersion
, "headline" .= eosResHeadline
, "release-notes" .= eosResReleaseNotes
]
toJSON EosRes {..} =
object ["version" .= eosResVersion, "headline" .= eosResHeadline, "release-notes" .= eosResReleaseNotes]
instance ToContent EosRes where
toContent = toContent . toJSON
instance ToTypedContent EosRes where
@@ -168,7 +164,7 @@ data PackageVersion = PackageVersion
} deriving (Show)
instance FromJSON PackageVersion where
parseJSON = withObject "package version" $ \o -> do
packageVersionId <- o .: "id"
packageVersionId <- o .: "id"
packageVersionVersion <- o .: "version"
pure PackageVersion { .. }
@@ -178,7 +174,7 @@ getCategoriesR = do
cats <- from $ table @Category
orderBy [desc (cats ^. CategoryPriority)]
pure cats
pure $ CategoryRes $ categoryName . entityVal <$>allCategories
pure $ CategoryRes $ categoryName . entityVal <$> allCategories
getEosR :: Handler EosRes
getEosR = do
@@ -186,71 +182,85 @@ getEosR = do
vers <- from $ table @OsVersion
orderBy [desc (vers ^. OsVersionCreatedAt)]
pure vers
let osV = entityVal <$> allEosVersions
let osV = entityVal <$> allEosVersions
let latest = Data.List.head osV
let mappedVersions = ReleaseNotes $ HM.fromList $ sortOn (Down . fst) $ (\v -> (osVersionNumber v, osVersionReleaseNotes v)) <$> osV
pure $ EosRes
{ eosResVersion = osVersionNumber latest
, eosResHeadline = osVersionHeadline latest
, eosResReleaseNotes = mappedVersions
}
let mappedVersions =
ReleaseNotes
$ HM.fromList
$ sortOn (Down . fst)
$ (\v -> (osVersionNumber v, osVersionReleaseNotes v))
<$> osV
pure $ EosRes { eosResVersion = osVersionNumber latest
, eosResHeadline = osVersionHeadline latest
, eosResReleaseNotes = mappedVersions
}
getReleaseNotesR :: Handler ReleaseNotes
getReleaseNotesR = do
getParameters <- reqGetParams <$> getRequest
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
(service, _) <- runDB $ fetchLatestApp package >>= errOnNothing status404 "package not found"
(_, mappedVersions) <- fetchAllAppVersions (entityKey service)
(service, _ ) <- runDB $ fetchLatestApp package >>= errOnNothing status404 "package not found"
(_ , mappedVersions) <- fetchAllAppVersions (entityKey service)
pure mappedVersions
getVersionLatestR :: Handler VersionLatestRes
getVersionLatestR = do
getParameters <- reqGetParams <$> getRequest
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
Left e -> sendResponseStatus status400 ("could not parse query param \"ids\"" <> show e :: Text)
Right (p :: [AppIdentifier])-> do
let packageList :: [(AppIdentifier, Maybe Version)] = (, Nothing) <$> p
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
Left e -> sendResponseStatus status400 ("could not parse query param \"ids\"" <> show e :: Text)
Right (p :: [AppIdentifier]) -> do
let packageList :: [(AppIdentifier, Maybe Version)] = (, Nothing) <$> p
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
getPackageListR :: Handler ServiceAvailableRes
getPackageListR = do
getParameters <- reqGetParams <$> getRequest
let defaults = ServiceListDefaults
{ serviceListOrder = DESC
, serviceListPageLimit = 20
, serviceListPageNumber = 1
, serviceListCategory = Nothing
, serviceListQuery = ""
}
let defaults = ServiceListDefaults { serviceListOrder = DESC
, serviceListPageLimit = 20
, serviceListPageNumber = 1
, serviceListCategory = Nothing
, serviceListQuery = ""
}
case lookup "ids" getParameters of
Nothing -> do
-- query for all
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 $ Just t
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 $ Just 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
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
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"
filteredServices <- runDB $ searchServices category limit' ((page - 1) * limit') query
-- domain <- getsYesod $ registryHostname . appSettings
@@ -260,84 +270,95 @@ getPackageListR = do
pure $ ServiceAvailableRes res
Just packageVersionList -> case eitherDecode $ BS.fromStrict $ encodeUtf8 packageVersionList of
Left e -> sendResponseStatus status400 ("could not parse query param \"ids\"" <> show e :: Text)
Right (packages :: [PackageVersion])-> do
-- for each item in list get best available from version range
availableServices <- traverse getPackageDetails packages
services <- traverse (uncurry getServiceDetails) availableServices
pure $ ServiceAvailableRes services
Left e -> sendResponseStatus status400 ("could not parse query param \"ids\"" <> show e :: Text)
Right (packages :: [PackageVersion]) -> do
-- for each item in list get best available from version range
availableServices <- traverse getPackageDetails packages
services <- traverse (uncurry getServiceDetails) availableServices
pure $ ServiceAvailableRes services
where
getPackageDetails :: PackageVersion -> HandlerFor RegistryCtx (Maybe (Entity SVersion), Entity SApp)
getPackageDetails pv = do
appsDir <- getsYesod $ ((</> "apps") . resourcesDir) . appSettings
let appId = packageVersionId pv
let spec = packageVersionVersion pv
let appId = packageVersionId pv
let spec = packageVersionVersion pv
let appExt = Extension (toS appId) :: Extension "s9pk"
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
(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)
getServiceR :: Handler ServiceRes
getServiceR = do
getParameters <- reqGetParams <$> getRequest
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
-- default to latest - @TODO need to determine best available based on OS version?
Nothing -> runDB $ fetchLatestApp appId' >>= errOnNothing status404 "service not found"
Just v -> do
case readMaybe v of
Nothing -> sendResponseStatus status400 ("Invalid App Version Specification" :: Text)
Just vv -> runDB $ fetchLatestAppAtVersion appId' vv >>= errOnNothing status404 ("service at version " <> show v <> " not found")
Nothing -> sendResponseStatus status404 ("id param should exist" :: Text)
Just appId' -> do
case lookup "version" getParameters of
-- default to latest - @TODO need to determine best available based on OS version?
Nothing -> runDB $ fetchLatestApp appId' >>= errOnNothing status404 "service not found"
Just v -> do
case readMaybe v of
Nothing -> sendResponseStatus status400 ("Invalid App Version Specification" :: Text)
Just vv -> runDB $ fetchLatestAppAtVersion appId' vv >>= errOnNothing
status404
("service at version " <> show v <> " not found")
getServiceDetails (Just version) service
getServiceDetails :: Maybe (Entity SVersion) -> Entity SApp -> HandlerFor RegistryCtx ServiceRes
getServiceDetails maybeVersion service = do
(versions, _) <- fetchAllAppVersions (entityKey service)
categories <- runDB $ fetchAppCategories (entityKey service)
(versions, _) <- fetchAllAppVersions (entityKey service)
categories <- runDB $ fetchAppCategories (entityKey service)
(appsDir, appMgrDir) <- getsYesod $ ((</> "apps") . resourcesDir &&& staticBinDir) . appSettings
domain <- getsYesod $ registryHostname . appSettings
domain <- getsYesod $ registryHostname . appSettings
let appId = sAppAppId $ entityVal service
version <- case maybeVersion of
Nothing -> do
(_, version) <- runDB $ fetchLatestApp appId >>= errOnNothing status404 "service not found"
pure $ sVersionNumber $ entityVal version
Just v -> pure $ sVersionNumber $ entityVal v
Nothing -> do
(_, version) <- runDB $ fetchLatestApp appId >>= errOnNothing status404 "service not found"
pure $ sVersionNumber $ entityVal version
Just v -> pure $ sVersionNumber $ entityVal v
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 -> pure a
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 -> pure a
d <- traverse (mapDependencyMetadata appsDir domain) (HM.toList $ serviceManifestDependencies manifest)
pure $ ServiceRes
{ serviceResIcon = [i|https://#{domain}/package/icon/#{appId}|]
, serviceResManifest = decode $ BS.fromStrict manifest' -- pass through raw JSON Value
, serviceResCategories = serviceCategoryCategoryName . entityVal <$> categories
, serviceResInstructions = [i|https://#{domain}/package/instructions/#{appId}|]
, serviceResLicense = [i|https://#{domain}/package/license/#{appId}|]
, serviceResVersions = versionInfoVersion <$> versions
, serviceResDependencyInfo = HM.fromList d
}
pure $ ServiceRes { serviceResIcon = [i|https://#{domain}/package/icon/#{appId}|]
, serviceResManifest = decode $ BS.fromStrict manifest' -- pass through raw JSON Value
, serviceResCategories = serviceCategoryCategoryName . entityVal <$> categories
, serviceResInstructions = [i|https://#{domain}/package/instructions/#{appId}|]
, serviceResLicense = [i|https://#{domain}/package/license/#{appId}|]
, serviceResVersions = versionInfoVersion <$> versions
, serviceResDependencyInfo = HM.fromList d
}
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
let ext = (Extension (toS appId) :: Extension "s9pk")
-- get best version from VersionRange of dependency
version <- getBestVersion appsDir ext (serviceDependencyInfoVersion depInfo) >>= \case
Nothing -> sendResponseStatus status404 ("best version not found for dependent package " <> appId :: Text)
Just v -> pure v
pure (appId, DependencyInfo
{ dependencyInfoTitle = appId
, dependencyInfoIcon = [i|https://#{domain}/package/icon/#{appId}?spec==#{version}|]
})
Just v -> pure v
pure
( appId
, DependencyInfo { dependencyInfoTitle = appId
, dependencyInfoIcon = [i|https://#{domain}/package/icon/#{appId}?spec==#{version}|]
}
)
decodeIcon :: (MonadHandler m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> m URL
decodeIcon appmgrPath depPath e@(Extension icon) = do
@@ -361,83 +382,86 @@ decodeLicense appmgrPath depPath package = do
fetchAllAppVersions :: Key SApp -> HandlerFor RegistryCtx ([VersionInfo], ReleaseNotes)
fetchAllAppVersions appId = do
entityAppVersions <- runDB $ P.selectList [SVersionAppId P.==. appId] [] -- orderby version
let vers = entityVal <$> entityAppVersions
let vv = mapSVersionToVersionInfo vers
let vers = entityVal <$> entityAppVersions
let vv = mapSVersionToVersionInfo vers
let mappedVersions = ReleaseNotes $ 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 [ desc (version ^. SVersionNumber) ]
limit 1
pure version
version <- from $ table @SVersion
where_ (version ^. SVersionAppId ==. val appId)
orderBy [desc (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)
(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 :: 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)
(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
(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
}
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) => Text -> Entity SApp -> ReaderT SqlBackend m ServiceAvailable
mapEntityToServiceAvailable :: (MonadIO m, MonadHandler m)
=> Text
-> Entity SApp
-> ReaderT SqlBackend m ServiceAvailable
mapEntityToServiceAvailable domain service = do
let appId = sAppAppId $ entityVal service
(_, 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 = [i|https://#{domain}/package/icon/#{appId}?spec==#{appVersion}|]
}
let appId = sAppAppId $ entityVal service
(_, 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 = [i|https://#{domain}/package/icon/#{appId}?spec==#{appVersion}|]
}
-- >>> encode hm
-- "{\"0.2.0\":\"some notes\"}"
hm :: Data.Aeson.Value
hm = object [ t .= v | (k,v) <- [("0.2.0", "some notes") :: (Version, Text)], let (String t) = toJSON k ]
hm = object [ t .= v | (k, v) <- [("0.2.0", "some notes") :: (Version, Text)], let (String t) = toJSON k ]
-- >>> encode rn
-- "{\"0.2.0\":\"notes one\",\"0.3.0\":\"notes two\"}"

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

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

8
src/Handler/Version.hs
View File

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

10
src/Lib/Error.hs
View File

@@ -11,7 +11,7 @@ import Data.String.Interpolate.IsString
type S9ErrT m = ExceptT S9Error m
data S9Error =
data S9Error =
PersistentE Text
| AppMgrE Text Int
deriving (Show, Eq)
@@ -21,10 +21,10 @@ instance Exception S9Error
-- | Redact any sensitive data in this function
toError :: S9Error -> Error
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}|]
data ErrorCode =
data ErrorCode =
DATABASE_ERROR
| APPMGR_ERROR
@@ -51,8 +51,8 @@ instance ToContent S9Error where
toStatus :: S9Error -> Status
toStatus = \case
PersistentE _ -> status500
AppMgrE _ _ -> status500
PersistentE _ -> status500
AppMgrE _ _ -> status500
handleS9ErrT :: MonadHandler m => S9ErrT m a -> m a

26
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 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
ExitSuccess -> pure out
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
(ec, bs) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "manifest", appPath <> show e] ""
case ec of
ExitSuccess -> pure bs
ExitSuccess -> pure bs
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
(ec, bs) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "icon", appPath] ""
case ec of
ExitSuccess -> pure bs
ExitSuccess -> pure bs
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
(ec, bs) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "hash", appPath <> show e] ""
case ec of
ExitSuccess -> pure bs
ExitSuccess -> pure bs
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
(ec, bs) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "instructions", appPath] ""
case ec of
ExitSuccess -> pure bs
ExitSuccess -> pure bs
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
(ec, bs) <- readProcessInheritStderr (appmgrPath <> "embassy-sdk") ["inspect", "license", appPath] ""
case ec of
ExitSuccess -> pure bs
ExitFailure n -> throwE $ AppMgrE [i|embassy-sdk inspect license #{appId}|] n
ExitSuccess -> pure bs
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
import Startlude hiding (words)
import Protolude.Unsafe
import Startlude hiding ( words )
import Protolude.Unsafe
import Data.String
import System.Process

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

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

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

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

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

@@ -48,8 +48,8 @@ import Control.Applicative ( liftA2
)
import Data.String ( IsString(..) )
import qualified Data.Text as T
import Data.Aeson
import Startlude (Hashable)
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, ToJSONKey, Hashable)

2
src/Orphans/Yesod.hs
View File

@@ -10,4 +10,4 @@ instance ToJSON a => ToContent [a] where
toContent = toContent . toJSON . fmap toJSON
instance ToJSON a => ToTypedContent [a] where
toTypedContent = toTypedContent . toJSON . fmap toJSON

6
src/Startlude.hs
View File

@@ -1,7 +1,7 @@
module Startlude
( module X
, module Startlude
)
( module X
, module Startlude
)
where
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 _ _ [] = Nothing
mapFind finder mapping (b:bs) = let
mB = mapFind finder mapping bs
mapFind finder mapping (b : bs) =
let mB = mapFind finder mapping bs
mA = finder [mapping b]
in case (mB, mA) of
(Just b',_) -> Just b'
(Nothing, Just _) -> Just b
_ -> Nothing
in case (mB, mA) of
(Just b', _ ) -> Just b'
(Nothing, Just _) -> Just b
_ -> Nothing

14
src/Util/Shared.hs
View File

@@ -2,7 +2,7 @@
module Util.Shared where
import Startlude hiding (Handler)
import Startlude hiding ( Handler )
import qualified Data.Text as T
import Network.HTTP.Types
@@ -12,8 +12,8 @@ import Foundation
import Lib.Registry
import Lib.Types.Emver
import Data.Semigroup
import Lib.External.AppMgr
import Lib.Error
import Lib.External.AppMgr
import Lib.Error
getVersionFromQuery :: KnownSymbol a => FilePath -> Extension a -> Handler (Maybe Version)
getVersionFromQuery rootDir ext = do
@@ -23,7 +23,11 @@ getVersionFromQuery rootDir ext = do
Just t -> pure t
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
-- @TODO change to db query?
appVersions <- liftIO $ getAvailableAppVersions rootDir ext
@@ -34,4 +38,4 @@ getBestVersion rootDir ext spec = do
addPackageHeader :: (MonadHandler m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> m ()
addPackageHeader appMgrDir appDir appExt = do
packageHash <- handleS9ErrT $ getPackageHash appMgrDir appDir appExt
addHeader "X-S9PK-HASH" $ decodeUtf8 packageHash
addHeader "X-S9PK-HASH" $ decodeUtf8 packageHash

147
test/Handler/AppSpec.hs
View File

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

190
test/Handler/MarketplaceSpec.hs
View File

@@ -1,79 +1,129 @@
{-# LANGUAGE TypeFamilies #-}
module Handler.MarketplaceSpec (spec) where
module Handler.MarketplaceSpec
( spec
)
where
import Startlude hiding (Any)
import Database.Persist.Sql
import Data.Maybe
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
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 "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
@@ -81,4 +131,4 @@ spec = do
-- _ <- 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
-- print res

8
test/Main.hs
View File

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

2
test/Spec.hs
View File

@@ -1 +1 @@
{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}
{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}

6
test/TestImport.hs
View File

@@ -8,7 +8,7 @@ module TestImport
)
where
import Startlude hiding (Handler)
import Startlude hiding ( Handler )
import Application ( makeFoundation
, makeLogWare
)
@@ -23,8 +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
import Database.Esqueleto.Internal.Internal
import Database.Persist.Sql.Types.Internal
runHandler :: Handler a -> YesodExample RegistryCtx a
runHandler handler = do