From d3c4772b0520eb0eb4961b23453b890bec7f4f40 Mon Sep 17 00:00:00 2001 From: Lucy Cifferello <12953208+elvece@users.noreply.github.com> Date: Thu, 23 Sep 2021 19:18:25 -0600 Subject: [PATCH] format all the things --- app/DevelMain.hs | 79 +++---- app/devel.hs | 6 +- app/main.hs | 2 +- src/Database/Marketplace.hs | 60 ++--- src/Handler/Apps.hs | 8 +- src/Handler/Icons.hs | 14 +- src/Handler/Marketplace.hs | 396 +++++++++++++++++--------------- src/Handler/Types/Status.hs | 6 +- src/Handler/Version.hs | 8 +- src/Lib/Error.hs | 10 +- src/Lib/External/AppMgr.hs | 26 ++- src/Lib/SystemCtl.hs | 4 +- src/Lib/Types/AppIndex.hs | 63 ++--- src/Lib/Types/Category.hs | 46 ++-- src/Lib/Types/Emver.hs | 4 +- src/Orphans/Yesod.hs | 2 +- src/Startlude.hs | 6 +- src/Util/Function.hs | 12 +- src/Util/Shared.hs | 14 +- test/Handler/AppSpec.hs | 147 ++++++------ test/Handler/MarketplaceSpec.hs | 190 +++++++++------ test/Main.hs | 8 +- test/Spec.hs | 2 +- test/TestImport.hs | 6 +- 24 files changed, 604 insertions(+), 515 deletions(-) diff --git a/app/DevelMain.hs b/app/DevelMain.hs index bf86185..34abcd5 100644 --- a/app/DevelMain.hs +++ b/app/DevelMain.hs @@ -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 diff --git a/app/devel.hs b/app/devel.hs index efc07ae..a52a0dc 100644 --- a/app/devel.hs +++ b/app/devel.hs @@ -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 \ No newline at end of file +main = develMain diff --git a/app/main.hs b/app/main.hs index b94ea16..035cf55 100644 --- a/app/main.hs +++ b/app/main.hs @@ -1,4 +1,4 @@ -import Application (appMain) +import Application ( appMain ) import Startlude main :: IO () diff --git a/src/Database/Marketplace.hs b/src/Database/Marketplace.hs index 680446e..7bed768 100644 --- a/src/Database/Marketplace.hs +++ b/src/Database/Marketplace.hs @@ -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] \ No newline at end of file +-- 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] diff --git a/src/Handler/Apps.hs b/src/Handler/Apps.hs index 496109e..7f8d1ed 100644 --- a/src/Handler/Apps.hs +++ b/src/Handler/Apps.hs @@ -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) - + diff --git a/src/Handler/Icons.hs b/src/Handler/Icons.hs index 60468f5..7dadaba 100644 --- a/src/Handler/Icons.hs +++ b/src/Handler/Icons.hs @@ -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 diff --git a/src/Handler/Marketplace.hs b/src/Handler/Marketplace.hs index 0f4f996..46f0968 100644 --- a/src/Handler/Marketplace.hs +++ b/src/Handler/Marketplace.hs @@ -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\"}" diff --git a/src/Handler/Types/Status.hs b/src/Handler/Types/Status.hs index 5afdc1a..51b56f7 100644 --- a/src/Handler/Types/Status.hs +++ b/src/Handler/Types/Status.hs @@ -3,7 +3,7 @@ {-# LANGUAGE NamedFieldPuns #-} module Handler.Types.Status where -import Startlude 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 \ No newline at end of file + toTypedContent = toTypedContent . toJSON diff --git a/src/Handler/Version.hs b/src/Handler/Version.hs index d506857..74cd75f 100644 --- a/src/Handler/Version.hs +++ b/src/Handler/Version.hs @@ -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) \ No newline at end of file + pure $ liftA3 AppVersionRes av (pure Nothing) (pure Nothing) diff --git a/src/Lib/Error.hs b/src/Lib/Error.hs index d30c496..aa67125 100644 --- a/src/Lib/Error.hs +++ b/src/Lib/Error.hs @@ -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 diff --git a/src/Lib/External/AppMgr.hs b/src/Lib/External/AppMgr.hs index af05155..f5c9784 100644 --- a/src/Lib/External/AppMgr.hs +++ b/src/Lib/External/AppMgr.hs @@ -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 \ No newline at end of file + ExitSuccess -> pure bs + ExitFailure n -> throwE $ AppMgrE [i|embassy-sdk inspect license #{appId}|] n diff --git a/src/Lib/SystemCtl.hs b/src/Lib/SystemCtl.hs index 0800f00..d661352 100644 --- a/src/Lib/SystemCtl.hs +++ b/src/Lib/SystemCtl.hs @@ -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 diff --git a/src/Lib/Types/AppIndex.hs b/src/Lib/Types/AppIndex.hs index 22a20fc..da8bc99 100644 --- a/src/Lib/Types/AppIndex.hs +++ b/src/Lib/Types/AppIndex.hs @@ -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 ] diff --git a/src/Lib/Types/Category.hs b/src/Lib/Types/Category.hs index a49fac4..d302ae9 100644 --- a/src/Lib/Types/Category.hs +++ b/src/Lib/Types/Category.hs @@ -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 \ No newline at end of file + toTypedContent = toTypedContent . toJSON diff --git a/src/Lib/Types/Emver.hs b/src/Lib/Types/Emver.hs index 285f905..0c9a356 100644 --- a/src/Lib/Types/Emver.hs +++ b/src/Lib/Types/Emver.hs @@ -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) diff --git a/src/Orphans/Yesod.hs b/src/Orphans/Yesod.hs index c07fc37..88bc30a 100644 --- a/src/Orphans/Yesod.hs +++ b/src/Orphans/Yesod.hs @@ -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 - \ No newline at end of file + diff --git a/src/Startlude.hs b/src/Startlude.hs index 4a22c47..e8bfd34 100644 --- a/src/Startlude.hs +++ b/src/Startlude.hs @@ -1,7 +1,7 @@ module Startlude - ( module X - , module Startlude - ) + ( module X + , module Startlude + ) where import Control.Arrow as X diff --git a/src/Util/Function.hs b/src/Util/Function.hs index da4ee4b..cb5c771 100644 --- a/src/Util/Function.hs +++ b/src/Util/Function.hs @@ -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 diff --git a/src/Util/Shared.hs b/src/Util/Shared.hs index bc9fde3..03a2daa 100644 --- a/src/Util/Shared.hs +++ b/src/Util/Shared.hs @@ -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 \ No newline at end of file + addHeader "X-S9PK-HASH" $ decodeUtf8 packageHash diff --git a/test/Handler/AppSpec.hs b/test/Handler/AppSpec.hs index e2b7fa2..46b860e 100644 --- a/test/Handler/AppSpec.hs +++ b/test/Handler/AppSpec.hs @@ -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\":{}}" diff --git a/test/Handler/MarketplaceSpec.hs b/test/Handler/MarketplaceSpec.hs index c4a790b..c7d87f8 100644 --- a/test/Handler/MarketplaceSpec.hs +++ b/test/Handler/MarketplaceSpec.hs @@ -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 \ No newline at end of file + -- print res diff --git a/test/Main.hs b/test/Main.hs index f3031d9..ff3522c 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -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 () diff --git a/test/Spec.hs b/test/Spec.hs index b7fb4ef..5416ef6 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1 +1 @@ -{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-} \ No newline at end of file +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-} diff --git a/test/TestImport.hs b/test/TestImport.hs index 92652ef..6fd65e2 100644 --- a/test/TestImport.hs +++ b/test/TestImport.hs @@ -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