From 86938c674b83e9bf720ae8197cf5eb859ee75fee Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9ophile=20Choutri?= Date: Sun, 6 Feb 2022 22:00:35 +0100 Subject: [PATCH] Starting the V1 search engine --- .github/workflows/ci.yml | 26 ++++++- Makefile | 8 +- assets/tailwind.config.js | 1 + flora.cabal | 2 + migrations/20211106003401_create_packages.sql | 3 + src/Flora/Import/Package.hs | 78 ++++++++++--------- src/Flora/Model/Category/Query.hs | 15 ++-- src/Flora/Model/Package/Query.hs | 58 +++++++++++++- src/Flora/Search.hs | 34 ++++++++ src/FloraWeb/Routes/Pages.hs | 2 + src/FloraWeb/Routes/Pages/Packages.hs | 13 +++- src/FloraWeb/Server/Pages.hs | 21 +++++ src/FloraWeb/Server/Pages/Packages.hs | 9 ++- src/FloraWeb/Session.hs | 10 ++- src/FloraWeb/Templates/Layout/App.hs | 6 +- src/FloraWeb/Templates/Packages/Listing.hs | 1 + .../Templates/Pages/Categories/Index.hs | 11 +-- src/FloraWeb/Templates/Pages/Home.hs | 16 ++-- src/FloraWeb/Templates/Pages/Search.hs | 32 ++++++++ test/Flora/PackageSpec.hs | 26 ++++++- test/fixtures/Cabal/Win32.cabal | 1 - 21 files changed, 292 insertions(+), 81 deletions(-) create mode 100644 src/Flora/Search.hs create mode 100644 src/FloraWeb/Templates/Pages/Search.hs diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 1c62c501..8f127af4 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -8,8 +8,22 @@ on: jobs: tests: runs-on: ubuntu-latest + # Service containers to run with `container-job` + services: + # Label used to access the service container + postgres: + # Docker Hub image + image: postgres + # Provide the password for postgres + env: + POSTGRES_PASSWORD: postgres + # Set health checks to wait until postgres has started + options: >- + --health-cmd pg_isready + --health-interval 10s + --health-timeout 5s + --health-retries 5 steps: - - uses: actions/checkout@v2.3.1 - name: Set up Haskell @@ -39,3 +53,13 @@ jobs: make build - name: Test run: make test + env: + FLORA_DB_DATABASE: flora_test + FLORA_DB_PASSWORD: postgres + FLORA_DB_POOL_CONNECTIONS: 10 + FLORA_DB_POST: 5432 + FLORA_DB_SUB_POOLS: 10 + FLORA_DB_TIMEOUT: 10 + FLORA_DB_USER: postgres + FLORA_LOGGING_DESTINATION: stdout + FLORA_HTTP_PORT: 8083 diff --git a/Makefile b/Makefile index c97d79c4..cc9768e9 100644 --- a/Makefile +++ b/Makefile @@ -10,13 +10,13 @@ clean: ## Remove the cabal build artifacts assets-deps: ## Install the dependencies of the frontend @cd assets/ && yarn -assets-build: assets-deps ## Build the web assets +build-assets: assets-deps ## Build the web assets @cd assets/ && yarn build -assets-watch: ## Continuously rebuild the web assets +watch-assets: ## Continuously rebuild the web assets @cd assets/ && yarn watch -assets-clean: ## Remove JS artifacts +clean-assets: ## Remove JS artifacts @cd assets/ && rm -R node_modules db-create: ## Create the database @@ -42,7 +42,7 @@ ghci: repl ## Start a cabal REPL (alias for `make repl`) watch: soufflé ## Load the main library and reload on file change @ghcid --target flora-server -l -test : soufflé ## Run the test suite +test: soufflé ## Run the test suite ./scripts/run-tests.sh watch-test: soufflé ## Load the tests in ghcid and reload them on file change diff --git a/assets/tailwind.config.js b/assets/tailwind.config.js index 84537c50..cf0b9685 100644 --- a/assets/tailwind.config.js +++ b/assets/tailwind.config.js @@ -12,6 +12,7 @@ module.exports = { colors: { "background": { "dark": "#25282a", + "dark-focused": "#3a3d3f", "DEFAULT": "#f3f4f6", }, "brand-purple": { diff --git a/flora.cabal b/flora.cabal index ec481a7c..6538564f 100644 --- a/flora.cabal +++ b/flora.cabal @@ -107,6 +107,7 @@ library Flora.Model.User.Query Flora.Model.User.Update Flora.Publish + Flora.Search Flora.ThirdParties.Hackage.API Flora.ThirdParties.Hackage.Client FloraWeb.Client @@ -141,6 +142,7 @@ library FloraWeb.Templates.Pages.Categories.Show FloraWeb.Templates.Pages.Home FloraWeb.Templates.Pages.Packages + FloraWeb.Templates.Pages.Search FloraWeb.Templates.Pages.Sessions FloraWeb.Templates.Types FloraWeb.Types diff --git a/migrations/20211106003401_create_packages.sql b/migrations/20211106003401_create_packages.sql index 368083e6..9c9d880d 100644 --- a/migrations/20211106003401_create_packages.sql +++ b/migrations/20211106003401_create_packages.sql @@ -1,3 +1,4 @@ +create extension if not exists pg_trgm; -- A package is comprised of metadata and has many releases. create table if not exists packages ( namespace text not null, @@ -9,3 +10,5 @@ create table if not exists packages ( updated_at timestamptz not null, primary key(namespace, name) ); + +create index package_name_namespace_trgm on packages USING GIN (name gin_trgm_ops); diff --git a/src/Flora/Import/Package.hs b/src/Flora/Import/Package.hs index 5dfa1ce9..235ea31a 100644 --- a/src/Flora/Import/Package.hs +++ b/src/Flora/Import/Package.hs @@ -1,6 +1,7 @@ {-# OPTIONS_GHC -Wno-unused-imports #-} module Flora.Import.Package where +import Control.Concurrent import Control.Monad.Except import qualified Data.ByteString as B import Data.Map (Map) @@ -72,6 +73,7 @@ coreLibraries = Set.fromList , PackageName "binary" , PackageName "bytestring" , PackageName "containers" + , PackageName "directory" , PackageName "deepseq" , PackageName "ghc-bignum" , PackageName "ghc-boot-th" @@ -116,44 +118,44 @@ importCabal :: (MonadIO m) -> FilePath -- ^ Directory where to find the .cabal files -> DBT m Package importCabal userId packageName cabalFile directory = do - genDesc <- liftIO $ loadFile cabalFile - let namespace = if Set.member packageName coreLibraries then Namespace "haskell" else Namespace "hackage" - result <- runExceptT $ do - package <- lift (Query.getHaskellOrHackagePackage packageName) - >>= \case - Nothing -> do - logImportMessage (namespace, packageName) $ - "\"" <> display packageName <> "\" could not be found in the database." - cabalToPackage userId (genDesc ^. #packageDescription) namespace packageName - Just package -> pure package - release <- lift $ - Query.getReleaseByVersion (package ^. #namespace, package ^. #name) - ((genDesc ^. #packageDescription) ^. (#package % #pkgVersion)) - >>= \case - Nothing -> do - r <- createRelease (package ^. #namespace) (package ^. #name) - ((genDesc ^. #packageDescription) ^. (#package % #pkgVersion)) - logImportMessage (namespace, packageName) $ "Creating Release " - <> display (r ^. #releaseId) <> " for package " <> display (package ^. #name) - pure r - Just release -> do - logImportMessage (namespace, packageName) $ - "Release found: releaseId: " <> display (release ^. #releaseId) <> " / packageId: " - pure release - componentsAndRequirements <- extractComponents userId directory - (namespace, packageName) - (flattenPackageDescription genDesc) - (release ^. #releaseId) - (package ^. #name) - let components = fmap fst componentsAndRequirements - let requirements = foldMap snd componentsAndRequirements - pure (package, release, components, requirements) - case result of - Left err -> error $ "Encountered error during import: " <> show err - Right (package, release, components, requirements) -> do - let rawCategoryField = T.pack $ Cabal.fromShortText $ genDesc ^. (#packageDescription % #category) - let categoryList = fmap (UserPackageCategory . T.stripStart) (T.splitOn "," rawCategoryField) - Update.publishPackage requirements components release categoryList package + let namespace = if Set.member packageName coreLibraries then Namespace "haskell" else Namespace "hackage" + genDesc <- liftIO $ loadFile cabalFile + result <- runExceptT $ do + package <- lift (Query.getHaskellOrHackagePackage packageName) + >>= \case + Nothing -> do + logImportMessage (namespace, packageName) $ + "\"" <> display packageName <> "\" could not be found in the database." + cabalToPackage userId (genDesc ^. #packageDescription) namespace packageName + Just package -> pure package + release <- lift $ + Query.getReleaseByVersion (package ^. #namespace, package ^. #name) + ((genDesc ^. #packageDescription) ^. (#package % #pkgVersion)) + >>= \case + Nothing -> do + r <- createRelease (package ^. #namespace) (package ^. #name) + ((genDesc ^. #packageDescription) ^. (#package % #pkgVersion)) + logImportMessage (namespace, packageName) $ "Creating Release " + <> display (r ^. #releaseId) <> " for package " <> display (package ^. #name) + pure r + Just release -> do + logImportMessage (namespace, packageName) $ + "Release found: releaseId: " <> display (release ^. #releaseId) <> " / packageId: " + pure release + componentsAndRequirements <- extractComponents userId directory + (namespace, packageName) + (flattenPackageDescription genDesc) + (release ^. #releaseId) + (package ^. #name) + let components = fmap fst componentsAndRequirements + let requirements = foldMap snd componentsAndRequirements + pure (package, release, components, requirements) + case result of + Left err -> error $ "Encountered error during import: " <> show err + Right (package, release, components, requirements) -> do + let rawCategoryField = T.pack $ Cabal.fromShortText $ genDesc ^. (#packageDescription % #category) + let categoryList = fmap (UserPackageCategory . T.stripStart) (T.splitOn "," rawCategoryField) + Update.publishPackage requirements components release categoryList package importPackageDeps :: (MonadIO m) => PackageName -> FilePath -> DBT m (Map PackageName (Set PackageName)) importPackageDeps pName directory = do diff --git a/src/Flora/Model/Category/Query.hs b/src/Flora/Model/Category/Query.hs index 23bc5a75..fec7f649 100644 --- a/src/Flora/Model/Category/Query.hs +++ b/src/Flora/Model/Category/Query.hs @@ -35,18 +35,17 @@ getPackagesFromCategorySlug slug = do Just Category{categoryId} -> do liftIO $ T.putStrLn "Category found!" query Select [sql| - select p.namespace, - p.name, - p.synopsis, - p.metadata, - p.owner_id, - p.created_at, - p.updated_at, + select p.namespace + , p.name + , p.synopsis + , p.metadata + , p.owner_id + , p.created_at + , p.updated_at from packages as p inner join package_categories as pc on (p.namespace = pc.package_namespace and p.name = pc.package_name) where pc.category_id = ? |] (Only categoryId) - -- joinSelectOneByField @Package @PackageCategory [field| package_id |] [field| category_id |] categoryId getAllCategories :: (MonadIO m) => DBT m (Vector Category) getAllCategories = query_ Select (_select @Category) diff --git a/src/Flora/Model/Package/Query.hs b/src/Flora/Model/Package/Query.hs index dd8b4268..a1f8e11c 100644 --- a/src/Flora/Model/Package/Query.hs +++ b/src/Flora/Model/Package/Query.hs @@ -6,7 +6,8 @@ module Flora.Model.Package.Query where import Control.Monad.IO.Class (MonadIO) import Data.Text (Text) import Data.Vector (Vector) -import Database.PostgreSQL.Entity (_select, _selectWhere, selectById) +import Database.PostgreSQL.Entity (_select, _selectWhere, selectById, + selectManyByField) import Database.PostgreSQL.Entity.DBT (QueryNature (Select), query, queryOne, query_) import Database.PostgreSQL.Entity.Types (Field, field) @@ -15,7 +16,7 @@ import Database.PostgreSQL.Simple.SqlQQ (sql) import Database.PostgreSQL.Transact (DBT) import Distribution.Types.Version (Version) import Flora.Model.Category (Category, CategoryId) -import Flora.Model.Package (Namespace, Package, PackageName) +import Flora.Model.Package (Namespace (..), Package, PackageName) import Flora.Model.Package.Component (ComponentId, ComponentType, PackageComponent) import Flora.Model.Release (ReleaseId) @@ -23,6 +24,9 @@ import Flora.Model.Release (ReleaseId) getAllPackages :: (MonadIO m) => DBT m (Vector Package) getAllPackages = query_ Select (_select @Package) +getPackagesByNamespace :: Namespace -> DBT IO (Vector Package) +getPackagesByNamespace namespace = selectManyByField @Package [field| namespace |] (Only namespace) + getPackageByNamespaceAndName :: (MonadIO m) => Namespace -> PackageName -> DBT m (Maybe Package) getPackageByNamespaceAndName namespace name = queryOne Select (_selectWhere @Package [[field| namespace |], [field| name |]]) @@ -111,8 +115,6 @@ getPackageCategories namespace packageName = query Select and pc.package_name = ? |] (namespace, packageName) - -- joinSelectOneByField @Category @PackageCategory [field| category_id |] [field| package_namespace |] packageId - getPackagesFromCategoryWithLatestVersion :: MonadIO m => CategoryId -> DBT m (Vector (Namespace, PackageName, Text, Version)) @@ -126,3 +128,51 @@ getPackagesFromCategoryWithLatestVersion categoryId = query Select q (Only categ inner join categories as c on c.category_id = pc.category_id where c.category_id = ? |] + +searchPackage :: Text -> DBT IO (Vector (Namespace, PackageName, Text, Version, Float)) +searchPackage searchString = query Select [sql| + SELECT lv."namespace" + , lv."name" + , lv."synopsis" + , lv."version" + , word_similarity(lv.name, ?) as rating + FROM latest_versions as lv + WHERE ? <% lv.name + GROUP BY + lv."namespace" + , lv."name" + , lv."synopsis" + , lv."version" + ORDER BY rating desc, count(lv."namespace") desc, lv.name asc; + |] (searchString, searchString) + +listAllPackages :: DBT IO (Vector (Namespace, PackageName, Text, Version, Float)) +listAllPackages = query_ Select [sql| + SELECT lv."namespace" + , lv."name" + , lv."synopsis" + , lv."version" + , (1.0::real) as rating + FROM latest_versions as lv + GROUP BY + lv."namespace" + , lv."name" + , lv."synopsis" + , lv."version" + ORDER BY rating desc, count(lv."namespace") desc, lv.name asc; + |] + +searchPackageByNamespace :: Namespace -> Text -> DBT IO (Vector (Namespace, PackageName, Text, Float)) +searchPackageByNamespace (Namespace namespace) searchString = query Select [sql| + SELECT p."namespace" + , p."name" + , p."synopsis" + , word_similarity(p.name, ?) as rating + FROM packages as p + WHERE ? <% p.name + AND p."namespace" = ? + GROUP BY + p."namespace" + , p."name" + ORDER BY rating desc, count(p."namespace") desc, p.name asc; + |] (searchString, searchString, namespace) diff --git a/src/Flora/Search.hs b/src/Flora/Search.hs new file mode 100644 index 00000000..ba41b471 --- /dev/null +++ b/src/Flora/Search.hs @@ -0,0 +1,34 @@ +module Flora.Search where + +import Data.Text +import Data.Vector (Vector) + +import Control.Monad.IO.Class +import Database.PostgreSQL.Entity.DBT (withPool) +import Distribution.Types.Version (Version) +import Flora.Environment (FloraEnv (..)) +import Flora.Model.Package (Namespace (..), PackageName) +import qualified Flora.Model.Package.Query as Query +import FloraWeb.Server.Auth (FloraPageM) +import FloraWeb.Session (Session (..), getSession) +import FloraWeb.Types (fetchFloraEnv) +import Optics.Core + +-- searchPackageByNamespace :: Namespace -> Text -> FloraPageM (Vector Package) +-- searchPackageByNamespace (Namespace namespace) query = undefined + +searchPackageByName :: Text -> FloraPageM (Vector (Namespace, PackageName, Text, Version)) +searchPackageByName queryString = do + session <- getSession + FloraEnv{pool} <- liftIO $ fetchFloraEnv (session ^. #webEnvStore) + results <- liftIO $ withPool pool $ Query.searchPackage queryString + let getInfo = (,,,) <$> view _1 <*> view _2 <*> view _3 <*> view _4 + pure $ fmap getInfo results + +listAllPackages :: FloraPageM (Vector (Namespace, PackageName, Text, Version)) +listAllPackages = do + session <- getSession + FloraEnv{pool} <- liftIO $ fetchFloraEnv (session ^. #webEnvStore) + results <- liftIO $ withPool pool Query.listAllPackages + let getInfo = (,,,) <$> view _1 <*> view _2 <*> view _3 <*> view _4 + pure $ fmap getInfo results diff --git a/src/FloraWeb/Routes/Pages.hs b/src/FloraWeb/Routes/Pages.hs index 1cdfc762..ef4fddd4 100644 --- a/src/FloraWeb/Routes/Pages.hs +++ b/src/FloraWeb/Routes/Pages.hs @@ -1,5 +1,6 @@ module FloraWeb.Routes.Pages where +import Data.Text import qualified FloraWeb.Routes.Pages.Admin as Admin import qualified FloraWeb.Routes.Pages.Categories as Categories import qualified FloraWeb.Routes.Pages.Packages as Packages @@ -18,5 +19,6 @@ data Routes' mode = Routes' , sessions :: mode :- "sessions" :> Sessions.Routes , packages :: mode :- "packages" :> Packages.Routes , categories :: mode :- "categories" :> Categories.Routes + , search :: mode :- "search" :> QueryParam "q" Text :> Get '[HTML] (Html ()) } deriving stock (Generic) diff --git a/src/FloraWeb/Routes/Pages/Packages.hs b/src/FloraWeb/Routes/Pages/Packages.hs index f56c3ebf..d1ecc254 100644 --- a/src/FloraWeb/Routes/Pages/Packages.hs +++ b/src/FloraWeb/Routes/Pages/Packages.hs @@ -1,6 +1,7 @@ module FloraWeb.Routes.Pages.Packages ( Routes , Routes'(..) + , GetRedirect ) where import Data.Text @@ -11,10 +12,16 @@ import Servant.HTML.Lucid type Routes = NamedRoutes Routes' +type GetRedirect + = Verb 'GET 301 '[HTML] (Headers '[Header "Location" Text] NoContent) + data Routes' mode = Routes' - { show :: mode :- Capture "namespace" Text :> Capture "package" Text - :> Get '[HTML] (Html ()) - , showVersion :: mode :- Capture "namespace" Text :> Capture "package" Text + { index :: mode :- GetRedirect + , show :: mode :- Capture "organisation" Text + :> Capture "package" Text + :> Get '[HTML] (Html ()) + , showVersion :: mode :- Capture "organisation" Text + :> Capture "package" Text :> Capture "version" Text :> Get '[HTML] (Html ()) } deriving stock (Generic) diff --git a/src/FloraWeb/Server/Pages.hs b/src/FloraWeb/Server/Pages.hs index 6c5d1fa8..f7f167f0 100644 --- a/src/FloraWeb/Server/Pages.hs +++ b/src/FloraWeb/Server/Pages.hs @@ -5,6 +5,8 @@ import Lucid import Optics.Core import Servant +import Data.Text (Text) +import qualified Flora.Search as Search import FloraWeb.Routes.Pages import FloraWeb.Server.Auth import qualified FloraWeb.Server.Pages.Admin as Admin @@ -14,6 +16,7 @@ import qualified FloraWeb.Server.Pages.Sessions as Sessions import FloraWeb.Session import FloraWeb.Templates import qualified FloraWeb.Templates.Pages.Home as Home +import qualified FloraWeb.Templates.Pages.Search as Search server :: ServerT Routes FloraPageM server = Routes' @@ -23,6 +26,7 @@ server = Routes' , sessions = Sessions.server , packages = Packages.server , categories = Categories.server + , search = searchHandler } homeHandler :: FloraPageM (Html ()) @@ -39,3 +43,20 @@ aboutHandler = do let (templateEnv :: TemplateEnv) = templateDefaults & #activeElements % #aboutNav .~ True render templateEnv Home.about + +searchHandler :: Maybe Text -> FloraPageM (Html ()) +searchHandler Nothing = searchHandler (Just "") +searchHandler (Just "") = do + session <- getSession + templateDefaults <- fromSession session defaultTemplateEnv + results <- Search.listAllPackages + let (templateEnv :: TemplateEnv) = + templateDefaults & #displayNavbarSearch .~ False + render templateEnv $ Search.showAllPackages results +searchHandler (Just searchString) = do + session <- getSession + templateDefaults <- fromSession session defaultTemplateEnv + results <- Search.searchPackageByName searchString + let (templateEnv :: TemplateEnv) = + templateDefaults & #displayNavbarSearch .~ False + render templateEnv $ Search.showResults searchString results diff --git a/src/FloraWeb/Server/Pages/Packages.hs b/src/FloraWeb/Server/Pages/Packages.hs index 69e0df7b..4305038e 100644 --- a/src/FloraWeb/Server/Pages/Packages.hs +++ b/src/FloraWeb/Server/Pages/Packages.hs @@ -25,19 +25,24 @@ import Flora.Model.Release import qualified Flora.Model.Release.Query as Query import FloraWeb.Routes.Pages.Packages import FloraWeb.Server.Auth +import FloraWeb.Server.Util (redirect) import FloraWeb.Session import FloraWeb.Templates import FloraWeb.Templates.Error import qualified FloraWeb.Templates.Pages.Packages as Packages import FloraWeb.Types -import Servant (ServerT) +import Servant (Header, Headers, NoContent, ServerT) server :: ServerT Routes FloraPageM server = Routes' - { show = showHandler + { index = indexHandler + , show = showHandler , showVersion = showVersionHandler } +indexHandler :: FloraPageM (Headers '[Header "Location" Text] NoContent) +indexHandler = pure $ redirect "/" + showHandler :: Text -> Text -> FloraPageM (Html ()) showHandler namespaceText nameText = do session <- getSession diff --git a/src/FloraWeb/Session.hs b/src/FloraWeb/Session.hs index 13225f56..a3791a16 100644 --- a/src/FloraWeb/Session.hs +++ b/src/FloraWeb/Session.hs @@ -1,4 +1,11 @@ -module FloraWeb.Session where +module FloraWeb.Session + ( module FloraWeb.Server.Auth.Types + , getSession + , craftSessionCookie + , emptySessionCookie + , addCookie + , deleteCookie + ) where import Control.Monad.Reader import Data.Kind @@ -6,6 +13,7 @@ import qualified Data.UUID as UUID import Servant (Header, Headers, addHeader, getResponse) import Web.Cookie + import Flora.Model.PersistentSession import FloraWeb.Server.Auth.Types diff --git a/src/FloraWeb/Templates/Layout/App.hs b/src/FloraWeb/Templates/Layout/App.hs index a3ceda63..60061df4 100644 --- a/src/FloraWeb/Templates/Layout/App.hs +++ b/src/FloraWeb/Templates/Layout/App.hs @@ -101,10 +101,10 @@ navbarSearch = do flag <- asks displayNavbarSearch if flag then do - form_ [class_ "w-full max-w-sm ml-5 inline-flex", action_ "#"] $ do + form_ [class_ "w-full max-w-sm ml-5 inline-flex", action_ "/search", method_ "GET"] $ do div_ [class_ "flex items-center py-2"] $ do input_ [ class_ "rounded-full bg:bg-background dark:bg-background-dark w-full mr-3 pl-3 py-1 px-1 leading-tight focus:outline-none border border-2 border-brand-purple" - , id_ "packageName", type_ "text", placeholder_ "Search a package" + , id_ "packageName", type_ "search", name_ "q", placeholder_ "Search a package" ] else pure mempty @@ -160,7 +160,7 @@ footer = div_ [class_ "mt-8 md:mt-0 md:order-1"] $ p_ [class_ "text-center text-base text-black dark:text-gray-400"] - "© 2021 Flora.pm. All rights reserved. Licensed under BSD-3-Clause." + "© 2022 Flora.pm. All rights reserved. Licensed under BSD-3-Clause." -- Helpers diff --git a/src/FloraWeb/Templates/Packages/Listing.hs b/src/FloraWeb/Templates/Packages/Listing.hs index 8292d685..96066690 100644 --- a/src/FloraWeb/Templates/Packages/Listing.hs +++ b/src/FloraWeb/Templates/Packages/Listing.hs @@ -1,4 +1,5 @@ module FloraWeb.Templates.Packages.Listing where + import Data.Text (Text) import Data.Text.Display (display) import Distribution.Types.Version (Version) diff --git a/src/FloraWeb/Templates/Pages/Categories/Index.hs b/src/FloraWeb/Templates/Pages/Categories/Index.hs index 9e1ee309..f32feb3e 100644 --- a/src/FloraWeb/Templates/Pages/Categories/Index.hs +++ b/src/FloraWeb/Templates/Pages/Categories/Index.hs @@ -15,8 +15,9 @@ index categories = do categoryCard :: Category -> FloraHTML categoryCard Category{name, slug, synopsis} = do - div_ [class_ "category-card max-w-md py-4 px-8 shadow-lg rounded-lg my-16"] $ do - div_ $ do - h2_ [class_ "font-semibold"] $ - a_ [class_ "category-name", href_ ("/categories/" <> slug)] (toHtml name) - p_ [class_ "mt-2 text-gray-200"] $ toHtml synopsis + a_ [class_ "category-name", href_ ("/categories/" <> slug)] $ + div_ [class_ "category-card max-w-md py-4 px-8 shadow-lg rounded-lg my-16"] $ do + div_ $ do + h2_ [class_ "font-semibold"] $ + p_ [class_ "category-name"] (toHtml name) + p_ [class_ "mt-2 text-gray-200"] $ toHtml synopsis diff --git a/src/FloraWeb/Templates/Pages/Home.hs b/src/FloraWeb/Templates/Pages/Home.hs index ca557e96..ef1ddc4f 100644 --- a/src/FloraWeb/Templates/Pages/Home.hs +++ b/src/FloraWeb/Templates/Pages/Home.hs @@ -70,10 +70,12 @@ banner = do searchBar :: FloraHTML searchBar = - div_ [class_ "main-search max-w-md mx-auto flex justify-center rounded-xl border-2 overflow-hidden"] $ do - input_ [ class_ "text-2xl text-gray-800 bg:bg-background dark:bg-background-dark dark:text-gray-300 block rounded-md border-0 focus-outline-none focus:ring-0 focus:brand-purple flex-grow p-2" - , type_ "search", name_ "search", placeholder_ "Find a package", value_ "", tabindex_ "1" - ] - button_ [ type_ "submit", class_ "items-center right-0 top-0 mt-5 mr-4 mb-5"] $ - svg_ [ xmlns_ "http://www.w3.org/2000/svg", class_ "h-6 w-6 my-auto m-2", style_ "color: gray", fill_ "none", viewBox_ "0 0 24 24", stroke_ "currentColor"] $ - path_ [stroke_linecap_ "round", stroke_linejoin_ "round", stroke_width_ "2", d_ "M21 21l-6-6m2-5a7 7 0 11-14 0 7 7 0 0114 0z"] + form_ [action_ "/search", method_ "GET"] $ do + div_ [class_ "main-search max-w-md mx-auto flex justify-center rounded-xl border-2 overflow-hidden dark:focus-within:bg-background-dark-focused "] $ do + input_ [ class_ "text-2xl text-gray-800 bg:bg-background dark:bg-background-dark dark:text-gray-300 block rounded-md border-0 \ + \ focus:outline-none focus:ring-0 focus:brand-purple flex-grow p-2 ml-2" + , type_ "search", name_ "q", placeholder_ "Find a package", value_ "", tabindex_ "1" + ] + button_ [ type_ "submit", class_ "items-center right-0 top-0 mt-5 mr-4 mb-5"] $ + svg_ [ xmlns_ "http://www.w3.org/2000/svg", class_ "h-6 w-6 my-auto m-2", style_ "color: gray", fill_ "none", viewBox_ "0 0 24 24", stroke_ "currentColor"] $ + path_ [stroke_linecap_ "round", stroke_linejoin_ "round", stroke_width_ "2", d_ "M21 21l-6-6m2-5a7 7 0 11-14 0 7 7 0 0114 0z"] diff --git a/src/FloraWeb/Templates/Pages/Search.hs b/src/FloraWeb/Templates/Pages/Search.hs new file mode 100644 index 00000000..a541961b --- /dev/null +++ b/src/FloraWeb/Templates/Pages/Search.hs @@ -0,0 +1,32 @@ +module FloraWeb.Templates.Pages.Search where + +import Data.Text +import Data.Text.Display (display) +import Data.Vector (Vector) +import qualified Data.Vector as V +import Distribution.Types.Version +import Flora.Model.Package (Namespace, PackageName) +import FloraWeb.Templates +import FloraWeb.Templates.Pages.Categories.Show (packageListing) +import Lucid + +showResults :: Text -> Vector (Namespace, PackageName, Text, Version) -> FloraHTML +showResults searchString packagesInfo = do + div_ [class_ "container dark:text-gray-100 text-black"] $ do + presentationHeader searchString (fromIntegral $ V.length packagesInfo) + packageListing packagesInfo + +showAllPackages :: Vector (Namespace, PackageName, Text, Version) -> FloraHTML +showAllPackages packagesInfo = do + div_ [class_ "container dark:text-gray-100 text-black"] $ do + presentationHeader "" (fromIntegral $ V.length packagesInfo) + packageListing packagesInfo + +presentationHeader :: Text -> Word -> FloraHTML +presentationHeader searchString numberOfPackages = do + div_ [class_ "divider"] $ do + div_ [class_ "px-4 py-5 sm:px-6 sm:py-24 lg:py-4 lg:px-8"] $ + h2_ [class_ "text-center text-2xl tracking-tight sm:text-2xl lg:text-5xl"] $ do + span_ [class_ "headline"] $ toHtml searchString + toHtmlRaw @Text " " + span_ [class_ "dark:text-gray-200 version"] $ toHtml $ display numberOfPackages <> " packages" diff --git a/test/Flora/PackageSpec.hs b/test/Flora/PackageSpec.hs index e35ed80f..87ee95d5 100644 --- a/test/Flora/PackageSpec.hs +++ b/test/Flora/PackageSpec.hs @@ -31,6 +31,8 @@ spec = testThese "packages" , testThis "Insert containers and its dependencies" testInsertContainers , testThis "@haskell/base belongs to the \"Prelude\" category" testThatBaseisInPreludeCategory , testThis "@hackage/semigroups belongs to appropriate categories" testThatSemigroupsIsInMathematicsAndDataStructures + , testThis "The \"haskell\" namespace has the correct number of packages" testCorrectNumberInHaskellNamespace + , testThis "Searching for \"base\" returns the correct results" testSearchingForBase ] testGetPackageById :: TestM () @@ -59,10 +61,10 @@ testInsertContainers = do testFetchGHCPrimDependents :: TestM () testFetchGHCPrimDependents = do - result <- liftDB $ Query.getPackageDependents (Namespace "haskell") (PackageName "ghc-prim") - assertEqual - (Set.fromList [PackageName "base", PackageName "ghc-bignum", PackageName "deepseq", PackageName "bytestring", PackageName "integer-gmp", PackageName "binary"]) - (Set.fromList . fmap (view #name) $ Vector.toList result) + result <- liftDB $ Query.getPackageDependents (Namespace "haskell") (PackageName "ghc-prim") + assertEqual + (Set.fromList [PackageName "base", PackageName "ghc-bignum", PackageName "deepseq", PackageName "bytestring", PackageName "integer-gmp", PackageName "binary"]) + (Set.fromList . fmap (view #name) $ Vector.toList result) testThatBaseisInPreludeCategory :: TestM () testThatBaseisInPreludeCategory = do @@ -77,3 +79,19 @@ testThatSemigroupsIsInMathematicsAndDataStructures = do Just _semigroups <- liftDB $ Query.getPackageByNamespaceAndName (Namespace "hackage") (PackageName "semigroups") result <- liftDB $ Query.getPackageCategories (Namespace "hackage") (PackageName "semigroups") assertEqual (Set.fromList ["data-structures", "maths"]) (Set.fromList $ slug <$> V.toList result) + +testCorrectNumberInHaskellNamespace :: TestM () +testCorrectNumberInHaskellNamespace = do + liftDB $ importCabal (hackageUser ^. #userId) (PackageName "Cabal") "./test/fixtures/Cabal/Cabal.cabal" "./test/fixtures/Cabal/" + results <- liftDB $ Query.getPackagesByNamespace (Namespace "haskell") + assertEqual 21 (Vector.length results) + +testSearchingForBase :: TestM () +testSearchingForBase = do + liftDB $ importCabal (hackageUser ^. #userId) (PackageName "base") "./test/fixtures/Cabal/base.cabal" "./test/fixtures/Cabal/" + result <- liftDB $ Query.searchPackage "base" + assertEqual (Vector.fromList [(PackageName "base", 1)]) + (result <&> (,) <$> view _2 <*> view _5) + +testPackageSearchResultOrdering :: TestM () +testPackageSearchResultOrdering = undefined diff --git a/test/fixtures/Cabal/Win32.cabal b/test/fixtures/Cabal/Win32.cabal index 28230d0b..461b3835 100644 --- a/test/fixtures/Cabal/Win32.cabal +++ b/test/fixtures/Cabal/Win32.cabal @@ -25,7 +25,6 @@ Library if !os(windows) -- This package requires Windows to build - build-depends: unbuildable<0 buildable: False build-depends: base >= 4.5 && < 5, filepath