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

mass clean up of warnings, hints, errors

Browse Source
This commit is contained in:
Keagan McClelland
2022-05-26 18:26:16 -06:00
parent 3d8b4057df
commit 2105c58182
27 changed files with 681 additions and 386 deletions
Download Patch File Download Diff File Expand all files Collapse all files

151
src/Application.hs
View File

@@ -27,13 +27,53 @@ module Application
, db , db
) where ) where
import Startlude hiding ( Handler ) import Startlude ( ($)
, (++)
, (.)
, (<$>)
, (<||>)
, Applicative(pure)
, Async(asyncThreadId)
, Bool(False, True)
, Either(Left, Right)
, Eq((==))
, ExitCode(ExitSuccess)
, IO
, Int
, Maybe(Just)
, Monad((>>=), return)
, MonadIO(..)
, Print(putStr, putStrLn)
, ReaderT(runReaderT)
, Text
, ThreadId
, async
, flip
, for_
, forever
, forkIO
, fromIntegral
, killThread
, newEmptyMVar
, newMVar
, onException
, panic
, print
, putMVar
, show
, stdout
, swapMVar
, takeMVar
, void
, waitEitherCatchCancel
, when
)
import Control.Monad.Logger ( LoggingT import Control.Monad.Logger ( LoggingT
, liftLoc , liftLoc
, runLoggingT , runLoggingT
) )
import Data.Default import Data.Default ( Default(def) )
import Database.Persist.Postgresql ( createPostgresqlPool import Database.Persist.Postgresql ( createPostgresqlPool
, pgConnStr , pgConnStr
, pgPoolSize , pgPoolSize
@@ -41,7 +81,11 @@ import Database.Persist.Postgresql ( createPostgresqlPool
, runSqlPool , runSqlPool
) )
import Language.Haskell.TH.Syntax ( qLocation ) import Language.Haskell.TH.Syntax ( qLocation )
import Network.Wai import Network.Wai ( Application
, Middleware
, Request(requestHeaders)
, ResponseReceived
)
import Network.Wai.Handler.Warp ( Settings import Network.Wai.Handler.Warp ( Settings
, defaultSettings , defaultSettings
, defaultShouldDisplayException , defaultShouldDisplayException
@@ -53,14 +97,19 @@ import Network.Wai.Handler.Warp ( Settings
, setPort , setPort
, setTimeout , setTimeout
) )
import Network.Wai.Handler.WarpTLS import Network.Wai.Handler.WarpTLS ( runTLS
, tlsSettings
)
import Network.Wai.Middleware.AcceptOverride import Network.Wai.Middleware.AcceptOverride
( acceptOverride )
import Network.Wai.Middleware.Autohead import Network.Wai.Middleware.Autohead
( autohead )
import Network.Wai.Middleware.Cors ( CorsResourcePolicy(..) import Network.Wai.Middleware.Cors ( CorsResourcePolicy(..)
, cors , cors
, simpleCorsResourcePolicy , simpleCorsResourcePolicy
) )
import Network.Wai.Middleware.MethodOverride import Network.Wai.Middleware.MethodOverride
( methodOverride )
import Network.Wai.Middleware.RequestLogger import Network.Wai.Middleware.RequestLogger
( Destination(Logger) ( Destination(Logger)
, OutputFormat(..) , OutputFormat(..)
@@ -75,28 +124,83 @@ import System.Log.FastLogger ( defaultBufSize
, newStdoutLoggerSet , newStdoutLoggerSet
, toLogStr , toLogStr
) )
import Yesod.Core import Yesod.Core ( HandlerFor
import Yesod.Core.Types hiding ( Logger ) , LogLevel(LevelError)
import Yesod.Default.Config2 , Yesod(messageLoggerSource)
, logInfo
, mkYesodDispatch
, toWaiAppPlain
, typeOctet
)
import Yesod.Core.Types ( Logger(loggerSet) )
import Yesod.Default.Config2 ( configSettingsYml
, develMainHelper
, getDevSettings
, loadYamlSettings
, loadYamlSettingsArgs
, makeYesodLogger
, useEnv
)
import Control.Lens import Control.Lens ( both )
import Data.List ( lookup ) import Data.List ( lookup )
import Data.String.Interpolate.IsString import Data.String.Interpolate.IsString
( i ) ( i )
import qualified Database.Persist.Migration import qualified Database.Persist.Migration
import qualified Database.Persist.Migration.Postgres import qualified Database.Persist.Migration.Postgres
import Database.Persist.Sql ( SqlBackend ) import Database.Persist.Sql ( SqlBackend )
import Foundation import Foundation ( Handler
import Handler.Admin , RegistryCtx(..)
import Handler.Apps , Route
import Handler.ErrorLogs ( AppManifestR
import Handler.Icons , AppR
import Handler.Marketplace , EosR
import Handler.Version , EosVersionR
, ErrorLogsR
, IconsR
, InfoR
, InstructionsR
, LicenseR
, PackageListR
, PkgDeindexR
, PkgIndexR
, PkgUploadR
, PkgVersionR
, ReleaseNotesR
, VersionLatestR
)
, resourcesRegistryCtx
, setWebProcessThreadId
, unsafeHandler
)
import Handler.Admin ( getPkgDeindexR
, postPkgDeindexR
, postPkgIndexR
, postPkgUploadR
)
import Handler.Apps ( getAppManifestR
, getAppR
)
import Handler.ErrorLogs ( postErrorLogsR )
import Handler.Icons ( getIconsR
, getInstructionsR
, getLicenseR
)
import Handler.Marketplace ( getEosR
, getEosVersionR
, getInfoR
, getPackageListR
, getReleaseNotesR
, getVersionLatestR
)
import Handler.Version ( getPkgVersionR )
import Lib.PkgRepository ( watchEosRepoRoot ) import Lib.PkgRepository ( watchEosRepoRoot )
import Lib.Ssl import Lib.Ssl ( doesSslNeedRenew
, renewSslCerts
, setupSsl
)
import Migration ( manualMigration ) import Migration ( manualMigration )
import Model import Model ( migrateAll )
import Network.HTTP.Types.Header ( hOrigin ) import Network.HTTP.Types.Header ( hOrigin )
import Network.Wai.Middleware.Gzip ( GzipFiles(GzipCompress) import Network.Wai.Middleware.Gzip ( GzipFiles(GzipCompress)
, GzipSettings(gzipCheckMime, gzipFiles) , GzipSettings(gzipCheckMime, gzipFiles)
@@ -104,12 +208,15 @@ import Network.Wai.Middleware.Gzip ( GzipFiles(GzipCompress)
, gzip , gzip
) )
import Network.Wai.Middleware.RequestLogger.JSON import Network.Wai.Middleware.RequestLogger.JSON
import Settings ( formatAsJSONWithHeaders )
import Settings ( AppPort
, AppSettings(..)
, configSettingsYmlValue
)
import System.Directory ( createDirectoryIfMissing ) import System.Directory ( createDirectoryIfMissing )
import System.Posix.Process import System.Posix.Process ( exitImmediately )
import System.Time.Extra import System.Time.Extra ( sleep )
import qualified UnliftIO import Yesod ( YesodPersist(runDB) )
import Yesod
-- This line actually creates our YesodDispatch instance. It is the second half -- This line actually creates our YesodDispatch instance. It is the second half
-- of the call to mkYesodData which occurs in Foundation.hs. Please see the -- of the call to mkYesodData which occurs in Foundation.hs. Please see the

43
src/Cli/Cli.hs
View File

@@ -25,15 +25,12 @@ import Control.Monad.Logger ( LogLevel(..)
import Crypto.Hash ( SHA256(SHA256) import Crypto.Hash ( SHA256(SHA256)
, hashWith , hashWith
) )
import Data.Aeson ( FromJSON import Data.Aeson ( eitherDecodeStrict )
, eitherDecodeStrict
)
import Data.ByteArray.Encoding ( Base(..) import Data.ByteArray.Encoding ( Base(..)
, convertToBase , convertToBase
) )
import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Char8 as B8
import qualified Data.ByteString.Lazy as LB import qualified Data.ByteString.Lazy as LB
import Data.Conduit.Process ( system )
import Data.Default import Data.Default
import Data.Functor.Contravariant ( contramap ) import Data.Functor.Contravariant ( contramap )
import Data.HashMap.Internal.Strict ( HashMap import Data.HashMap.Internal.Strict ( HashMap
@@ -44,7 +41,14 @@ import Data.HashMap.Internal.Strict ( HashMap
, traverseWithKey , traverseWithKey
) )
import Data.Text ( toLower ) import Data.Text ( toLower )
import Dhall hiding ( void ) import Dhall ( Encoder(embed)
, FromDhall(..)
, Generic
, ToDhall(..)
, auto
, inject
, inputFile
)
import Dhall.Core ( pretty ) import Dhall.Core ( pretty )
import Handler.Admin ( IndexPkgReq(IndexPkgReq) import Handler.Admin ( IndexPkgReq(IndexPkgReq)
, PackageList(..) , PackageList(..)
@@ -75,8 +79,29 @@ import Network.HTTP.Simple ( getResponseBody
import Network.URI ( URI import Network.URI ( URI
, parseURI , parseURI
) )
import Options.Applicative hiding ( auto import Options.Applicative ( (<$>)
, empty , (<**>)
, Alternative((<|>))
, Applicative((*>), (<*>), liftA2, pure)
, Parser
, ParserInfo
, command
, execParser
, fullDesc
, help
, helper
, info
, liftA3
, long
, mappend
, metavar
, optional
, progDesc
, short
, strArgument
, strOption
, subparser
, switch
) )
import Rainbow ( Chunk import Rainbow ( Chunk
, Radiant , Radiant
@@ -111,7 +136,6 @@ import Startlude ( ($)
, Show , Show
, String , String
, appendFile , appendFile
, asum
, const , const
, decodeUtf8 , decodeUtf8
, exitWith , exitWith
@@ -125,7 +149,6 @@ import Startlude ( ($)
, fst , fst
, headMay , headMay
, panic , panic
, putStrLn
, show , show
, snd , snd
, unlessM , unlessM
@@ -145,7 +168,6 @@ import System.FilePath ( (</>)
, takeDirectory , takeDirectory
, takeExtension , takeExtension
) )
import System.Process ( callCommand )
import System.ProgressBar ( Progress(..) import System.ProgressBar ( Progress(..)
, defStyle , defStyle
, newProgressBar , newProgressBar
@@ -154,7 +176,6 @@ import System.ProgressBar ( Progress(..)
import Yesod ( logError import Yesod ( logError
, logWarn , logWarn
) )
import Yesod.Core ( FromJSON(parseJSON) )
data Upload = Upload data Upload = Upload
{ publishRepoName :: String { publishRepoName :: String

55
src/Database/Marketplace.hs
View File

@@ -38,21 +38,54 @@ import Database.Esqueleto.Experimental
, (||.) , (||.)
) )
import qualified Database.Persist as P import qualified Database.Persist as P
import Database.Persist.Postgresql import Database.Persist.Postgresql ( ConnectionPool
hiding ( (==.) , Entity(entityKey, entityVal)
, getJust , PersistEntity(Key)
, selectSource , SqlBackend
, (||.) , runSqlPool
) )
import Handler.Types.Marketplace ( PackageDependencyMetadata(..) ) import Handler.Types.Marketplace ( PackageDependencyMetadata(..) )
import Lib.Types.AppIndex ( PkgId ) import Lib.Types.AppIndex ( PkgId )
import Lib.Types.Emver ( Version ) import Lib.Types.Emver ( Version )
import Model import Model ( Category
import Startlude hiding ( (%) , EntityField
, from ( CategoryId
, groupBy , CategoryName
, on , PkgCategoryCategoryId
, yield , PkgCategoryPkgId
, PkgDependencyDepId
, PkgDependencyPkgId
, PkgDependencyPkgVersion
, PkgRecordId
, VersionRecordDescLong
, VersionRecordDescShort
, VersionRecordPkgId
, VersionRecordTitle
, VersionRecordUpdatedAt
)
, Key(PkgRecordKey, unPkgRecordKey)
, PkgCategory
, PkgDependency
, PkgRecord
, VersionRecord(versionRecordNumber, versionRecordPkgId)
)
import Startlude ( ($)
, ($>)
, (.)
, (<$>)
, Applicative(pure)
, Down(Down)
, Eq((==))
, Functor(fmap)
, Maybe(..)
, Monad
, MonadIO
, ReaderT
, Text
, headMay
, lift
, snd
, sortOn
) )
type CategoryTitle = Text type CategoryTitle = Text

80
src/Foundation.hs
View File

@@ -13,8 +13,36 @@
module Foundation where module Foundation where
import Startlude hiding ( Handler import Startlude ( ($)
, get , (.)
, (<$>)
, (<&>)
, (<**>)
, (=<<)
, Applicative(pure)
, Bool(False)
, Eq((==))
, IO
, MVar
, Maybe(..)
, Monad(return)
, Monoid(mempty)
, Semigroup((<>))
, String
, Text
, ThreadId
, Word64
, decodeUtf8
, drop
, encodeUtf8
, flip
, fst
, isJust
, otherwise
, putMVar
, show
, when
, (||)
) )
import Control.Monad.Logger ( Loc import Control.Monad.Logger ( Loc
@@ -23,9 +51,37 @@ import Control.Monad.Logger ( Loc
, ToLogStr(toLogStr) , ToLogStr(toLogStr)
, fromLogStr , fromLogStr
) )
import Database.Persist.Sql hiding ( update ) import Database.Persist.Sql ( ConnectionPool
import Lib.Registry , LogFunc
import Yesod.Core , PersistStoreRead(get)
, SqlBackend
, SqlPersistT
, runSqlPool
)
import Lib.Registry ( S9PK )
import Yesod.Core ( AuthResult(Authorized, Unauthorized)
, LogLevel(..)
, MonadHandler(liftHandler)
, RenderMessage(..)
, RenderRoute(Route, renderRoute)
, RouteAttrs(routeAttrs)
, SessionBackend
, ToTypedContent
, Yesod
( isAuthorized
, makeLogger
, makeSessionBackend
, maximumContentLengthIO
, messageLoggerSource
, shouldLogIO
, yesodMiddleware
)
, defaultYesodMiddleware
, getYesod
, getsYesod
, mkYesodData
, parseRoutesFile
)
import Yesod.Core.Types ( HandlerData(handlerEnv) import Yesod.Core.Types ( HandlerData(handlerEnv)
, Logger(loggerDate) , Logger(loggerDate)
, RunHandlerEnv(rheChild, rheSite) , RunHandlerEnv(rheChild, rheSite)
@@ -43,12 +99,14 @@ import Data.String.Interpolate.IsString
( i ) ( i )
import qualified Data.Text as T import qualified Data.Text as T
import Language.Haskell.TH ( Loc(..) ) import Language.Haskell.TH ( Loc(..) )
import Lib.PkgRepository import Lib.PkgRepository ( EosRepo
import Lib.Types.AppIndex , PkgRepo
)
import Lib.Types.AppIndex ( PkgId )
import Model ( Admin(..) import Model ( Admin(..)
, Key(AdminKey) , Key(AdminKey)
) )
import Settings import Settings ( AppSettings(appShouldLogAll) )
import System.Console.ANSI.Codes ( Color(..) import System.Console.ANSI.Codes ( Color(..)
, ColorIntensity(..) , ColorIntensity(..)
, ConsoleLayer(Foreground) , ConsoleLayer(Foreground)
@@ -72,7 +130,11 @@ import Yesod.Auth ( AuthEntity
import Yesod.Auth.Http.Basic ( defaultAuthSettings import Yesod.Auth.Http.Basic ( defaultAuthSettings
, defaultMaybeBasicAuthId , defaultMaybeBasicAuthId
) )
import Yesod.Persist.Core import Yesod.Persist.Core ( DBRunner
, YesodPersist(..)
, YesodPersistRunner(..)
, defaultGetDBRunner
)
-- | The foundation datatype for your application. This can be a good place to -- | The foundation datatype for your application. This can be a good place to
-- keep settings and values requiring initialization before your application -- keep settings and values requiring initialization before your application

9
src/Handler/Admin.hs
View File

@@ -29,14 +29,15 @@ import Data.List ( (\\)
) )
import Data.String.Interpolate.IsString import Data.String.Interpolate.IsString
( i ) ( i )
import Database.Persist ( entityKey import Database.Persist ( entityVal
, entityVal
, insert_ , insert_
, selectList , selectList
) )
import Database.Persist.Postgresql ( runSqlPoolNoTransaction ) import Database.Persist.Postgresql ( runSqlPoolNoTransaction )
import Database.Queries ( upsertPackageVersion ) import Database.Queries ( upsertPackageVersion )
import Foundation import Foundation ( Handler
, RegistryCtx(appConnPool)
)
import Lib.PkgRepository ( PkgRepo(PkgRepo, pkgRepoFileRoot) import Lib.PkgRepository ( PkgRepo(PkgRepo, pkgRepoFileRoot)
, extractPkg , extractPkg
, getManifestLocation , getManifestLocation
@@ -71,13 +72,11 @@ import Startlude ( ($)
, asum , asum
, fmap , fmap
, getCurrentTime , getCurrentTime
, guard
, guarded , guarded
, hush , hush
, isNothing , isNothing
, liftIO , liftIO
, not , not
, panic
, replicate , replicate
, show , show
, throwIO , throwIO

18
src/Handler/Apps.hs
View File

@@ -9,7 +9,17 @@
module Handler.Apps where module Handler.Apps where
import Startlude hiding ( Handler ) import Startlude ( ($)
, (.)
, Applicative(pure)
, FilePath
, Maybe(..)
, Monad((>>=))
, Show
, String
, show
, void
)
import Control.Monad.Logger ( logError ) import Control.Monad.Logger ( logError )
import qualified Data.Text as T import qualified Data.Text as T
@@ -88,16 +98,16 @@ getAppR file = do
recordMetrics :: PkgId -> Version -> Handler () recordMetrics :: PkgId -> Version -> Handler ()
recordMetrics pkg appVersion = do recordMetrics pkg appVersion = do
sa <- runDB $ fetchApp $ pkg sa <- runDB $ fetchApp pkg
case sa of case sa of
Nothing -> do Nothing -> do
$logError $ [i|#{pkg} not found in database|] $logError [i|#{pkg} not found in database|]
notFound notFound
Just _ -> do Just _ -> do
existingVersion <- runDB $ fetchAppVersion pkg appVersion existingVersion <- runDB $ fetchAppVersion pkg appVersion
case existingVersion of case existingVersion of
Nothing -> do Nothing -> do
$logError $ [i|#{pkg}@#{appVersion} not found in database|] $logError [i|#{pkg}@#{appVersion} not found in database|]
notFound notFound
Just _ -> runDB $ createMetric pkg appVersion Just _ -> runDB $ createMetric pkg appVersion

13
src/Handler/ErrorLogs.hs
View File

@@ -6,11 +6,20 @@ import Data.Aeson ( (.:)
, FromJSON(parseJSON) , FromJSON(parseJSON)
, withObject , withObject
) )
import Foundation import Foundation ( Handler )
import Model ( EntityField(ErrorLogRecordIncidents) import Model ( EntityField(ErrorLogRecordIncidents)
, ErrorLogRecord(ErrorLogRecord) , ErrorLogRecord(ErrorLogRecord)
) )
import Startlude hiding ( Handler ) import Startlude ( ($)
, Applicative(pure)
, Eq
, MonadIO(liftIO)
, Show
, Text
, Word32
, getCurrentTime
, void
)
import Yesod.Core ( requireCheckJsonBody ) import Yesod.Core ( requireCheckJsonBody )
import Yesod.Persist ( (+=.) import Yesod.Persist ( (+=.)
, runDB , runDB

29
src/Handler/Icons.hs
View File

@@ -8,24 +8,41 @@
module Handler.Icons where module Handler.Icons where
import Startlude hiding ( Handler ) import Startlude ( ($)
, Eq
, Generic
, Read
, Show
, show
)
import Data.Conduit ( (.|) import Data.Conduit ( (.|)
, awaitForever , awaitForever
) )
import Data.String.Interpolate.IsString import Data.String.Interpolate.IsString
( i ) ( i )
import Foundation import Foundation ( Handler )
import Lib.Error ( S9Error(NotFoundE) ) import Lib.Error ( S9Error(NotFoundE) )
import Lib.PkgRepository ( getBestVersion import Lib.PkgRepository ( getBestVersion
, getIcon , getIcon
, getInstructions , getInstructions
, getLicense , getLicense
) )
import Lib.Types.AppIndex import Lib.Types.AppIndex ( PkgId )
import Network.HTTP.Types import Network.HTTP.Types ( status400 )
import Util.Shared import Util.Shared ( getVersionSpecFromQuery
import Yesod.Core , orThrow
, versionPriorityFromQueryIsMin
)
import Yesod.Core ( FromJSON
, ToJSON
, TypedContent
, addHeader
, respondSource
, sendChunkBS
, sendResponseStatus
, typePlain
)
data IconType = PNG | JPG | JPEG | SVG data IconType = PNG | JPG | JPEG | SVG
deriving (Eq, Show, Generic, Read) deriving (Eq, Show, Generic, Read)

74
src/Handler/Marketplace.hs
View File

@@ -10,13 +10,48 @@
module Handler.Marketplace where module Handler.Marketplace where
import Startlude hiding ( Any import Startlude ( ($)
, Handler , (&&&)
, ask , (.)
, concurrently , (<$>)
, from , (<&>)
, on , Applicative((*>), pure)
, sortOn , Bool(True)
, ByteString
, Down(Down)
, Either(Left, Right)
, FilePath
, Foldable(foldMap)
, Functor(fmap)
, Int
, Maybe(..)
, Monad((>>=))
, MonadIO
, MonadReader
, Monoid(mappend)
, Num((*), (-))
, Ord((<))
, ReaderT(runReaderT)
, Text
, Traversable(traverse)
, catMaybes
, const
, decodeUtf8
, encodeUtf8
, filter
, flip
, for_
, fromMaybe
, fst
, head
, headMay
, id
, maybe
, partitionEithers
, readMaybe
, show
, snd
, void
) )
import Conduit ( (.|) import Conduit ( (.|)
@@ -45,7 +80,7 @@ import Data.Attoparsec.Text ( Parser
import Data.ByteArray.Encoding ( Base(..) import Data.ByteArray.Encoding ( Base(..)
, convertToBase , convertToBase
) )
import Data.ByteString.Base64 import Data.ByteString.Base64 ( encodeBase64 )
import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Lazy as LBS
import qualified Data.Conduit.List as CL import qualified Data.Conduit.List as CL
import qualified Data.HashMap.Strict as HM import qualified Data.HashMap.Strict as HM
@@ -84,7 +119,26 @@ import Foundation ( Handler
, RegistryCtx(appConnPool, appSettings) , RegistryCtx(appConnPool, appSettings)
, Route(InstructionsR, LicenseR) , Route(InstructionsR, LicenseR)
) )
import Handler.Types.Marketplace import Handler.Types.Marketplace ( CategoryTitle
, DependencyRes(..)
, EosRes(..)
, InfoRes(InfoRes)
, OrderArrangement(DESC)
, PackageListDefaults
( PackageListDefaults
, packageListCategory
, packageListOrder
, packageListPageLimit
, packageListPageNumber
, packageListQuery
)
, PackageListRes(..)
, PackageMetadata(..)
, PackageReq(packageReqId, packageReqVersion)
, PackageRes(..)
, ReleaseNotes(ReleaseNotes)
, VersionLatestRes(..)
)
import Lib.Error ( S9Error(..) ) import Lib.Error ( S9Error(..) )
import Lib.PkgRepository ( PkgRepo import Lib.PkgRepository ( PkgRepo
, getIcon , getIcon
@@ -110,7 +164,7 @@ import Network.HTTP.Types ( status400
, status404 , status404
) )
import Protolude.Unsafe ( unsafeFromJust ) import Protolude.Unsafe ( unsafeFromJust )
import Settings import Settings ( AppSettings(marketplaceName, resourcesDir) )
import System.FilePath ( (</>) ) import System.FilePath ( (</>) )
import UnliftIO.Async ( mapConcurrently ) import UnliftIO.Async ( mapConcurrently )
import UnliftIO.Directory ( listDirectory ) import UnliftIO.Directory ( listDirectory )

26
src/Handler/Types/Marketplace.hs
View File

@@ -2,7 +2,14 @@
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
module Handler.Types.Marketplace where module Handler.Types.Marketplace where
import Data.Aeson import Data.Aeson ( (.:)
, FromJSON(parseJSON)
, KeyValue((.=))
, ToJSON(toJSON)
, Value(String)
, object
, withObject
)
import qualified Data.HashMap.Internal.Strict as HM import qualified Data.HashMap.Internal.Strict as HM
import Lib.Types.AppIndex ( PkgId ) import Lib.Types.AppIndex ( PkgId )
import Lib.Types.Emver ( Version import Lib.Types.Emver ( Version
@@ -13,8 +20,21 @@ import Model ( Category
, PkgRecord , PkgRecord
, VersionRecord , VersionRecord
) )
import Startlude import Startlude ( ($)
import Yesod , (.)
, Applicative(pure)
, Eq
, Generic
, Int
, Maybe
, Read
, Show
, Text
)
import Yesod ( Entity
, ToContent(..)
, ToTypedContent(..)
)
type URL = Text type URL = Text

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

@@ -1,14 +1,24 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Use newtype instead of data" #-}
module Handler.Types.Status where module Handler.Types.Status where
import Startlude hiding ( toLower ) import Startlude ( (.)
, Eq
, Maybe
, Show
)
import Data.Aeson import Data.Aeson ( KeyValue((.=))
import Yesod.Core.Content , ToJSON(toJSON)
, object
)
import Yesod.Core.Content ( ToContent(..)
, ToTypedContent(..)
)
import Lib.Types.Emver import Lib.Types.Emver ( Version )
import Orphans.Emver ( ) import Orphans.Emver ( )
data AppVersionRes = AppVersionRes data AppVersionRes = AppVersionRes
@@ -16,7 +26,7 @@ data AppVersionRes = AppVersionRes
} }
deriving (Eq, Show) deriving (Eq, Show)
instance ToJSON AppVersionRes where instance ToJSON AppVersionRes where
toJSON AppVersionRes { appVersionVersion } = object $ ["version" .= appVersionVersion] toJSON AppVersionRes { appVersionVersion } = object ["version" .= appVersionVersion]
instance ToContent AppVersionRes where instance ToContent AppVersionRes where
toContent = toContent . toJSON toContent = toContent . toJSON
instance ToTypedContent AppVersionRes where instance ToTypedContent AppVersionRes where

9
src/Handler/Version.hs
View File

@@ -1,5 +1,4 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
@@ -7,14 +6,14 @@
module Handler.Version where module Handler.Version where
import Startlude hiding ( Handler ) import Startlude ( (<$>) )
import Yesod.Core import Yesod.Core ( sendResponseStatus )
import Data.String.Interpolate.IsString import Data.String.Interpolate.IsString
( i ) ( i )
import Foundation import Foundation ( Handler )
import Handler.Types.Status import Handler.Types.Status ( AppVersionRes(AppVersionRes) )
import Lib.Error ( S9Error(NotFoundE) ) import Lib.Error ( S9Error(NotFoundE) )
import Lib.PkgRepository ( getBestVersion ) import Lib.PkgRepository ( getBestVersion )
import Lib.Types.AppIndex ( PkgId ) import Lib.Types.AppIndex ( PkgId )

25
src/Lib/Error.hs
View File

@@ -3,11 +3,30 @@
module Lib.Error where module Lib.Error where
import Startlude import Startlude ( (.)
, Eq
, ExceptT
, Exception
, ExitCode
, Show
, Text
, show
)
import Data.String.Interpolate.IsString import Data.String.Interpolate.IsString
import Network.HTTP.Types ( i )
import Yesod.Core import Network.HTTP.Types ( Status
, status400
, status404
, status500
)
import Yesod.Core ( (.=)
, ToContent(..)
, ToJSON(toJSON)
, ToTypedContent(..)
, Value(String)
, object
)
type S9ErrT m = ExceptT S9Error m type S9ErrT m = ExceptT S9Error m

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

@@ -11,15 +11,46 @@
module Lib.External.AppMgr where module Lib.External.AppMgr where
import Startlude hiding ( bracket import Startlude ( ($)
, catch , (&&)
, finally , (<$>)
, handle , Applicative((*>), pure)
, ByteString
, Eq((==))
, ExitCode
, FilePath
, Monad
, MonadIO(..)
, Monoid
, String
, atomically
, id
, liftA3
, stderr
, throwIO
) )
import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Lazy as LBS
import Data.String.Interpolate.IsString import Data.String.Interpolate.IsString
import System.Process.Typed hiding ( createPipe ) ( i )
import System.Process.Typed ( ExitCodeException(eceExitCode)
, Process
, ProcessConfig
, byteStringInput
, byteStringOutput
, getStderr
, getStdout
, proc
, setEnvInherit
, setStderr
, setStdin
, setStdout
, startProcess
, stopProcess
, useHandleOpen
, waitExitCodeSTM
, withProcessWait
)
import Conduit ( (.|) import Conduit ( (.|)
, ConduitT , ConduitT
@@ -29,11 +60,11 @@ import Control.Monad.Logger ( MonadLoggerIO
, logErrorSH , logErrorSH
) )
import qualified Data.Conduit.List as CL import qualified Data.Conduit.List as CL
import Data.Conduit.Process.Typed import Data.Conduit.Process.Typed ( createSource )
import GHC.IO.Exception ( IOErrorType(NoSuchThing) import GHC.IO.Exception ( IOErrorType(NoSuchThing)
, IOException(ioe_description, ioe_type) , IOException(ioe_description, ioe_type)
) )
import Lib.Error import Lib.Error ( S9Error(AppMgrE) )
import System.FilePath ( (</>) ) import System.FilePath ( (</>) )
import UnliftIO ( MonadUnliftIO import UnliftIO ( MonadUnliftIO
, bracket , bracket

7
src/Lib/PkgRepository.hs
View File

@@ -71,7 +71,12 @@ import Lib.Types.Emver ( Version
, parseVersion , parseVersion
, satisfies , satisfies
) )
import Model import Model ( EntityField(EosHashHash, PkgRecordUpdatedAt)
, EosHash(EosHash)
, Key(PkgRecordKey)
, PkgDependency(PkgDependency)
, PkgRecord(PkgRecord)
)
import Startlude ( ($) import Startlude ( ($)
, (&&) , (&&)
, (.) , (.)

21
src/Lib/Registry.hs
View File

@@ -5,12 +5,27 @@
module Lib.Registry where module Lib.Registry where
import Startlude import Startlude ( ($)
, (.)
, ConvertText(toS)
, Eq((==))
, KnownSymbol
, Proxy(Proxy)
, Read
, Show
, String
, Symbol
, readMaybe
, show
, symbolVal
)
import qualified GHC.Read ( Read(..) ) import qualified GHC.Read ( Read(..) )
import qualified GHC.Show ( Show(..) ) import qualified GHC.Show ( Show(..) )
import System.FilePath import System.FilePath ( (<.>)
import Yesod.Core , splitExtension
)
import Yesod.Core ( PathPiece(..) )
newtype Extension (a :: Symbol) = Extension String deriving (Eq) newtype Extension (a :: Symbol) = Extension String deriving (Eq)
type S9PK = Extension "s9pk" type S9PK = Extension "s9pk"

29
src/Lib/Ssl.hs
View File

@@ -2,15 +2,34 @@
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
module Lib.Ssl where module Lib.Ssl where
import System.Directory import System.Directory ( doesPathExist )
import System.Process import System.Process ( rawSystem
, system
)
import Data.String.Interpolate.IsString import Data.String.Interpolate.IsString
( i )
import Startlude import Startlude ( ($)
, (&&&)
, (.)
, (<&&>)
, Applicative(pure)
, Bool
, Eq((/=))
, ExitCode(ExitSuccess)
, IO
, MonadIO(liftIO)
, ReaderT
, Semigroup((<>))
, Text
, asks
, unless
, void
)
import Foundation import Foundation ( RegistryCtx(appSettings) )
import Settings import Settings ( AppSettings(..) )
-- openssl genrsa -out key.pem 2048 -- openssl genrsa -out key.pem 2048
-- openssl req -new -key key.pem -out certificate.csr -- openssl req -new -key key.pem -out certificate.csr

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

@@ -22,6 +22,7 @@ import qualified Data.ByteString.Lazy as BS
import Data.Functor.Contravariant ( contramap ) import Data.Functor.Contravariant ( contramap )
import qualified Data.HashMap.Strict as HM import qualified Data.HashMap.Strict as HM
import Data.String.Interpolate.IsString import Data.String.Interpolate.IsString
( i )
import qualified Data.Text as T import qualified Data.Text as T
import Database.Persist ( PersistField(..) import Database.Persist ( PersistField(..)
, PersistValue(PersistText) , PersistValue(PersistText)

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

@@ -36,10 +36,41 @@ module Lib.Types.Emver
, parseRange , parseRange
) where ) where
import Startlude hiding ( Any ) import Startlude ( ($)
, ($>)
, (&&)
, (.)
, (<$>)
, (<&>)
, (<<$>>)
, Alternative((<|>))
, Applicative((*>), (<*), liftA2, pure)
, Bool(..)
, Either(..)
, Eq(..)
, Foldable(foldMap, length)
, Hashable
, IsString(..)
, Monad((>>=))
, Monoid(mappend, mempty)
, Num((+))
, Ord(compare)
, Ordering(..)
, Read
, Semigroup((<>))
, Show
, String
, Word
, either
, flip
, id
, on
, show
, (||)
)
import Control.Monad.Fail ( fail ) import Control.Monad.Fail ( fail )
import Data.Aeson import Data.Aeson ( ToJSONKey )
import qualified Data.Attoparsec.Text as Atto import qualified Data.Attoparsec.Text as Atto
import qualified Data.Text as T import qualified Data.Text as T
import GHC.Base ( error ) import GHC.Base ( error )
@@ -205,7 +236,7 @@ parseVersion = do
-- >>> Atto.parseOnly parseRange ">=2.14.1.1 <3.0.0" -- >>> Atto.parseOnly parseRange ">=2.14.1.1 <3.0.0"
-- Right >=2.14.1.1 <3.0.0 -- Right >=2.14.1.1 <3.0.0
parseRange :: Atto.Parser VersionRange parseRange :: Atto.Parser VersionRange
parseRange = s <|> (Atto.char '*' *> pure Any) <|> (Anchor (Right EQ) <$> parseVersion) parseRange = s <|> (Atto.char '*' $> Any) <|> (Anchor (Right EQ) <$> parseVersion)
where where
sub = Atto.char '(' *> Atto.skipSpace *> parseRange <* Atto.skipSpace <* Atto.char ')' sub = Atto.char '(' *> Atto.skipSpace *> parseRange <* Atto.skipSpace <* Atto.char ')'
s = s =

11
src/Migration.hs
View File

@@ -1,6 +1,15 @@
module Migration where module Migration where
import Database.Persist.Migration import Database.Persist.Migration ( Column(Column)
, ColumnProp(NotNull)
, MigrateSql(MigrateSql)
, Migration
, MigrationPath((:=))
, Operation(AddColumn, DropColumn, RawOperation)
, PersistValue(PersistText)
, SqlType(SqlString)
, rawSql
)
import Database.Persist.Sql ( Single(..) ) import Database.Persist.Sql ( Single(..) )
import Startlude ( ($) import Startlude ( ($)
, (<<$>>) , (<<$>>)

25
src/Model.hs
View File

@@ -11,13 +11,28 @@
module Model where module Model where
import Crypto.Hash import Crypto.Hash ( Digest
import Database.Persist.TH , SHA256
import Lib.Types.AppIndex )
import Lib.Types.Emver import Database.Persist.TH ( mkMigrate
, mkPersist
, persistLowerCase
, share
, sqlSettings
)
import Lib.Types.AppIndex ( PkgId(PkgId) )
import Lib.Types.Emver ( Version
, VersionRange
)
import Orphans.Cryptonite ( ) import Orphans.Cryptonite ( )
import Orphans.Emver ( ) import Orphans.Emver ( )
import Startlude import Startlude ( Eq
, Int
, Show
, Text
, UTCTime
, Word32
)
share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
PkgRecord PkgRecord

27
src/Orphans/Emver.hs
View File

@@ -4,15 +4,34 @@
-- aeson, persistent, and yesod are not. So we put those here as they will not be extracted into a separate library. -- aeson, persistent, and yesod are not. So we put those here as they will not be extracted into a separate library.
module Orphans.Emver where module Orphans.Emver where
import Startlude import Startlude ( ($)
, (.)
, (<=<)
, Applicative(pure)
, Bifunctor(first)
, either
, show
)
import Data.Aeson import Data.Aeson ( FromJSON(parseJSON)
, ToJSON(toJSON)
, Value(String)
, withText
)
import qualified Data.Attoparsec.Text as Atto import qualified Data.Attoparsec.Text as Atto
import Control.Monad.Fail ( MonadFail(fail) ) import Control.Monad.Fail ( MonadFail(fail) )
import qualified Data.Text as T import qualified Data.Text as T
import Database.Persist.Sql import Database.Persist.Sql ( PersistField(..)
import Lib.Types.Emver , PersistFieldSql(..)
, PersistValue(PersistText)
, SqlType(SqlString)
)
import Lib.Types.Emver ( Version
, VersionRange
, parseRange
, parseVersion
)
instance FromJSON Version where instance FromJSON Version where
parseJSON = withText "Emver Version" $ either fail pure . Atto.parseOnly parseVersion parseJSON = withText "Emver Version" $ either fail pure . Atto.parseOnly parseVersion

36
src/Settings.hs
View File

@@ -9,16 +9,40 @@
module Settings where module Settings where
import Paths_start9_registry ( version ) import Paths_start9_registry ( version )
import Startlude import Startlude ( ($)
, (.)
, (<$>)
, Applicative(liftA2)
, Bool(..)
, ByteString
, ConvertText(toS)
, FilePath
, IsString(fromString)
, Monad(return)
, Monoid(mempty)
, Text
, Word16
, either
, id
, panic
)
import qualified Control.Exception as Exception import qualified Control.Exception as Exception
import Data.Aeson import Data.Aeson ( (.!=)
import Data.Aeson.Types , (.:)
, (.:?)
, FromJSON(parseJSON)
, Result(Error, Success)
, Value(String)
, fromJSON
, withObject
)
import Data.Aeson.Types ( parseMaybe )
import Data.FileEmbed ( embedFile ) import Data.FileEmbed ( embedFile )
import Data.Maybe import Data.Maybe ( fromJust )
import Data.Version ( showVersion ) import Data.Version ( showVersion )
import Data.Yaml ( decodeEither' ) import Data.Yaml ( decodeEither' )
import Data.Yaml.Config import Data.Yaml.Config ( applyEnvValue )
import Database.Persist.Postgresql ( PostgresConf ) import Database.Persist.Postgresql ( PostgresConf )
import Network.Wai.Handler.Warp ( HostPreference ) import Network.Wai.Handler.Warp ( HostPreference )
import System.FilePath ( (</>) import System.FilePath ( (</>)
@@ -30,7 +54,7 @@ import Control.Monad.Reader.Has ( Has(extract, update) )
import Lib.PkgRepository ( EosRepo(EosRepo, eosRepoFileRoot) import Lib.PkgRepository ( EosRepo(EosRepo, eosRepoFileRoot)
, PkgRepo(..) , PkgRepo(..)
) )
import Lib.Types.Emver import Lib.Types.Emver ( Version )
import Orphans.Emver ( ) import Orphans.Emver ( )
-- | Runtime settings to configure this application. These settings can be -- | Runtime settings to configure this application. These settings can be
-- loaded from various sources: defaults, environment variables, config files, -- loaded from various sources: defaults, environment variables, config files,

24
src/Util/Shared.hs
View File

@@ -10,8 +10,20 @@ module Util.Shared where
import qualified Data.Text as T import qualified Data.Text as T
import Network.HTTP.Types import Network.HTTP.Types ( Status
import Yesod.Core , status400
)
import Yesod.Core ( MonadHandler
, MonadLogger
, MonadUnliftIO
, ToContent(toContent)
, TypedContent(TypedContent)
, addHeader
, logInfo
, lookupGetParam
, sendResponseStatus
, typePlain
)
import Conduit ( ConduitT import Conduit ( ConduitT
, awaitForever , awaitForever
@@ -28,7 +40,7 @@ import Database.Esqueleto.Experimental
, Key , Key
, entityVal , entityVal
) )
import Foundation import Foundation ( Handler )
import GHC.List ( lookup ) import GHC.List ( lookup )
import Handler.Types.Marketplace ( PackageDependencyMetadata(..) import Handler.Types.Marketplace ( PackageDependencyMetadata(..)
, PackageMetadata(..) , PackageMetadata(..)
@@ -37,7 +49,11 @@ import Lib.PkgRepository ( PkgRepo
, getHash , getHash
) )
import Lib.Types.AppIndex ( PkgId ) import Lib.Types.AppIndex ( PkgId )
import Lib.Types.Emver import Lib.Types.Emver ( (<||)
, Version
, VersionRange(Any)
, satisfies
)
import Model ( Category import Model ( Category
, PkgDependency(pkgDependencyDepId, pkgDependencyDepVersionRange) , PkgDependency(pkgDependencyDepId, pkgDependencyDepVersionRange)
, PkgRecord , PkgRecord

140
test/Handler/AppSpec.hs
View File

@@ -1,140 +0,0 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE QuasiQuotes #-}
module Handler.AppSpec
( spec
) where
import Data.Maybe
import Database.Persist.Sql
import Startlude
import Data.Aeson
import Data.Aeson.Types ( parseEither )
import Data.String.Interpolate.IsString
( i )
import Handler.Types.Marketplace ( PackageRes(packageResDependencies, packageResManifest) )
import Lib.Types.AppIndex
import Model
import Seed
import TestImport
spec :: Spec
spec = do
describe "GET /package/index" $ withApp $ it "returns list of packages" $ do
_ <- seedBitcoinLndStack
request $ do
setMethod "GET"
setUrl ("/package/index" :: Text)
statusIs 200
(res :: [PackageRes]) <- requireJSONResponse
assertEq "response should have two packages" (length res) 3
describe "GET /package/index?ids" $ withApp $ it "returns list of packages at specified version" $ do
_ <- seedBitcoinLndStack
request $ do
setMethod "GET"
setUrl ("/package/index?ids=[{\"id\":\"bitcoind\",\"version\":\"=0.21.1.2\"}]" :: Text)
statusIs 200
(res :: [PackageRes]) <- requireJSONResponse
assertEq "response should have one package" (length res) 1
let pkg = fromJust $ head res
(manifest :: PackageManifest) <- either (\e -> panic [i|failed to parse package manifest: #{e}|])
pure
(parseEither parseJSON $ packageResManifest pkg)
assertEq "manifest id should be bitcoind" (packageManifestId manifest) "bitcoind"
describe "GET /package/index?ids"
$ withApp
$ it "returns list of packages and dependencies at specified version"
$ do
_ <- seedBitcoinLndStack
request $ do
setMethod "GET"
setUrl ("/package/index?ids=[{\"id\":\"lnd\",\"version\":\"=0.13.3.1\"}]" :: Text)
statusIs 200
(res :: [PackageRes]) <- requireJSONResponse
assertEq "response should have one package" (length res) 1
let pkg = fromJust $ head res
assertEq "package dependency metadata should not be empty" (null $ packageResDependencies pkg) False
describe "GET /package/index?ids" $ withApp $ it "returns list of packages at exactly specified version" $ do
_ <- seedBitcoinLndStack
request $ do
setMethod "GET"
setUrl ("/package/index?ids=[{\"id\":\"bitcoind\",\"version\":\"=0.21.1.1\"}]" :: Text)
statusIs 200
(res :: [PackageRes]) <- requireJSONResponse
assertEq "response should have one package" (length res) 1
let pkg = fromJust $ head res
(manifest :: PackageManifest) <- either (\e -> panic [i|failed to parse package manifest: #{e}|])
pure
(parseEither parseJSON $ packageResManifest pkg)
assertEq "manifest version should be 0.21.1.1" (packageManifestVersion manifest) "0.21.1.1"
describe "GET /package/index?ids" $ withApp $ it "returns list of packages at specified version or greater" $ do
_ <- seedBitcoinLndStack
request $ do
setMethod "GET"
setUrl ("/package/index?ids=[{\"id\":\"bitcoind\",\"version\":\">=0.21.1.1\"}]" :: Text)
statusIs 200
(res :: [PackageRes]) <- requireJSONResponse
assertEq "response should have one package" (length res) 1
let pkg = fromJust $ head res
(manifest :: PackageManifest) <- either (\e -> panic [i|failed to parse package manifest: #{e}|])
pure
(parseEither parseJSON $ packageResManifest pkg)
assertEq "manifest version should be 0.21.1.2" (packageManifestVersion manifest) "0.21.1.2"
describe "GET /package/index?ids" $ withApp $ it "returns list of packages at specified version or greater" $ do
_ <- seedBitcoinLndStack
request $ do
setMethod "GET"
setUrl ("/package/index?ids=[{\"id\":\"bitcoind\",\"version\":\">=0.21.1.2\"}]" :: Text)
statusIs 200
(res :: [PackageRes]) <- requireJSONResponse
assertEq "response should have one package" (length res) 1
let pkg = fromJust $ head res
(manifest :: PackageManifest) <- either (\e -> panic [i|failed to parse package manifest: #{e}|])
pure
(parseEither parseJSON $ packageResManifest pkg)
assertEq "manifest version should be 0.21.1.2" (packageManifestVersion manifest) "0.21.1.2"
describe "GET /package/:pkgId with unknown version spec for bitcoind" $ withApp $ it "fails to get unknown app" $ do
_ <- seedBitcoinLndStack
request $ do
setMethod "GET"
setUrl ("/package/bitcoind.s9pk?spec==0.20.0" :: Text)
statusIs 404
describe "GET /package/:pkgId with unknown package" $ withApp $ it "fails to get an unregistered app" $ do
_ <- seedBitcoinLndStack
request $ do
setMethod "GET"
setUrl ("/package/tempapp.s9pk?spec=0.0.1" :: Text)
statusIs 404
describe "GET /package/:pkgId with package at unknown version"
$ withApp
$ it "fails to get an unregistered app"
$ do
_ <- seedBitcoinLndStack
request $ do
setMethod "GET"
setUrl ("/package/lightning.s9pk?spec==0.0.1" :: Text)
statusIs 404
describe "GET /package/:pkgId with existing version spec for bitcoind"
$ withApp
$ it "creates app and metric records"
$ do
_ <- seedBitcoinLndStack
request $ do
setMethod "GET"
setUrl ("/package/bitcoind.s9pk?spec==0.21.1.2" :: Text)
statusIs 200
packages <- runDBtest $ selectList [PkgRecordId ==. PkgRecordKey "bitcoind"] []
assertEq "app should exist" (length packages) 1
let app = fromJust $ head packages
metrics <- runDBtest $ selectList [MetricPkgId ==. entityKey app] []
assertEq "metric should exist" (length metrics) 1
describe "GET /package/:pkgId with existing version spec for lnd" $ withApp $ it "creates metric records" $ do
_ <- seedBitcoinLndStack
request $ do
setMethod "GET"
setUrl ("/package/lnd.s9pk?spec=>=0.13.3.0" :: Text)
statusIs 200
metrics <- runDBtest $ selectList [MetricPkgId ==. PkgRecordKey "lnd"] []
assertEq "metric should exist" (length metrics) 1

55
test/Handler/MarketplaceSpec.hs
View File

@@ -1,55 +0,0 @@
{-# LANGUAGE TypeFamilies #-}
module Handler.MarketplaceSpec
( spec
)
where
import Data.Maybe
import Database.Persist.Sql
import Startlude hiding ( Any )
import Conduit ( (.|)
, runConduit
, sinkList
)
import Database.Marketplace
import Lib.Types.Category
import Model
import TestImport
import Seed
spec :: Spec
spec = do
describe "searchServices with category" $ withApp $ it "should filter services with featured category" $ do
_ <- seedBitcoinLndStack
packages <- runDBtest $ runConduit $ searchServices (Just FEATURED) "" .| sinkList
assertEq "should exist" (length packages) 1
let pkg = fromJust $ head packages
assertEq "should be bitcoin" (pkgRecordTitle $ entityVal pkg) "Bitcoin Core"
describe "searchServices with category" $ withApp $ it "should filter services with bitcoin category" $ do
_ <- seedBitcoinLndStack
packages <- runDBtest $ runConduit $ searchServices (Just BITCOIN) "" .| sinkList
assertEq "should exist" (length packages) 3
describe "searchServices with fuzzy query"
$ withApp
$ it "runs search service with fuzzy text in long description and no category"
$ do
_ <- seedBitcoinLndStack
packages <- runDBtest $ runConduit $ searchServices Nothing "lightning" .| sinkList
assertEq "should exist" (length packages) 1
let pkg = fromJust $ head packages
assertEq "package should be lnd" (entityKey pkg) (PkgRecordKey "lnd")
describe "searchServices with fuzzy query"
$ withApp
$ it "runs search service with fuzzy text in long description and bitcoin category"
$ do
_ <- seedBitcoinLndStack
packages <- runDBtest $ runConduit $ searchServices (Just BITCOIN) "proxy" .| sinkList
assertEq "should exist" (length packages) 1
let pkg = fromJust $ head packages
assertEq "package should be lnc" (entityKey pkg) (PkgRecordKey "btc-rpc-proxy")
describe "searchServices with any category" $ withApp $ it "runs search service for any category" $ do
_ <- seedBitcoinLndStack
packages <- runDBtest $ runConduit $ searchServices Nothing "" .| sinkList
assertEq "should exist" (length packages) 3

55
test/Seed.hs
View File

@@ -1,55 +0,0 @@
module Seed where
import Database.Persist.Sql ( PersistStoreWrite(insert, insertKey, insert_) )
import Model ( Category(Category)
, Key(PkgRecordKey)
, PkgCategory(PkgCategory)
, PkgDependency(PkgDependency)
, PkgRecord(PkgRecord)
, VersionRecord(VersionRecord)
)
import Startlude ( ($)
, Applicative(pure)
, Maybe(Just, Nothing)
, MonadIO(liftIO)
, getCurrentTime
)
import Lib.Types.Category ( CategoryTitle(BITCOIN, FEATURED, LIGHTNING) )
import Prelude ( read )
import TestImport ( RegistryCtx
, SIO
, YesodExampleData
, runDBtest
)
seedBitcoinLndStack :: SIO (YesodExampleData RegistryCtx) ()
seedBitcoinLndStack = runDBtest $ do
time <- liftIO getCurrentTime
insertKey (PkgRecordKey "bitcoind")
$ PkgRecord time (Just time) "Bitcoin Core" "short desc bitcoin" "long desc bitcoin" "png"
_ <- insert $ VersionRecord time (Just time) (PkgRecordKey "bitcoind") "0.21.1.2" "notes" "0.3.0" Nothing
_ <- insert $ VersionRecord time (Just time) (PkgRecordKey "bitcoind") "0.21.1.1" "notes" "0.3.0" Nothing
_ <- insertKey (PkgRecordKey "lnd")
$ PkgRecord time (Just time) "Lightning Network Daemon" "short desc lnd" "long desc lnd" "png"
_ <- insert $ VersionRecord time (Just time) (PkgRecordKey "lnd") "0.13.3.0" "notes" "0.3.0" Nothing
_ <- insert $ VersionRecord time (Just time) (PkgRecordKey "lnd") "0.13.3.1" "notes" "0.3.0" Nothing
_ <- insertKey (PkgRecordKey "btc-rpc-proxy")
$ PkgRecord time (Just time) "BTC RPC Proxy" "short desc btc-rpc-proxy" "long desc btc-rpc-proxy" "png"
_ <- insert $ VersionRecord time (Just time) (PkgRecordKey "btc-rpc-proxy") "0.3.2.1" "notes" "0.3.0" Nothing
featuredCat <- insert $ Category time FEATURED Nothing "desc" 0
btcCat <- insert $ Category time BITCOIN Nothing "desc" 0
lnCat <- insert $ Category time LIGHTNING Nothing "desc" 0
_ <- insert_ $ PkgCategory time (PkgRecordKey "bitcoind") featuredCat
_ <- insert_ $ PkgCategory time (PkgRecordKey "lnd") lnCat
_ <- insert_ $ PkgCategory time (PkgRecordKey "lnd") btcCat
_ <- insert_ $ PkgCategory time (PkgRecordKey "bitcoind") btcCat
_ <- insert_ $ PkgCategory time (PkgRecordKey "btc-rpc-proxy") btcCat
_ <- insert_
$ PkgDependency time (PkgRecordKey "lnd") "0.13.3.1" (PkgRecordKey "bitcoind") (read ">=0.21.1.2 <0.22.0")
_ <- insert_ $ PkgDependency time
(PkgRecordKey "lnd")
"0.13.3.1"
(PkgRecordKey "btc-rpc-proxy")
(read ">=0.3.2.1 <0.4.0")
pure ()