From 42466731b24dcfbb127736ea733ebb9edcde9cf8 Mon Sep 17 00:00:00 2001 From: Ivan Gromakovskii Date: Thu, 6 May 2021 20:13:36 +0300 Subject: [PATCH 1/2] Add experiments summary getter Problem: in order to construct dashboard selectors we use the `/experiments` endpoint to get all experiments. It sends a lot of data and works slowly, especially when we pass no filters. Solution: add another endpoints that returns only names of relevant projects, compounds and targets. It works much faster, returns less data and still makes it possible to construct selectors. In future we'll also add endpoints to query all project/compound/target names without querying all data about them. --- backend/src/Edna/DB/Integration.hs | 9 ++++ backend/src/Edna/Dashboard/DB/Query.hs | 71 ++++++++++++++++++++++++- backend/src/Edna/Dashboard/Service.hs | 34 +++++++++++- backend/src/Edna/Dashboard/Web/API.hs | 15 +++++- backend/src/Edna/Dashboard/Web/Types.hs | 45 +++++++++++++++- backend/src/Edna/Library/DB/Query.hs | 16 +++++- backend/src/Edna/Library/Service.hs | 4 ++ backend/test/Test/DashboardSpec.hs | 62 +++++++++++++++++++-- backend/test/Test/Gen.hs | 13 +++++ backend/test/Test/LibrarySpec.hs | 16 ++++-- 10 files changed, 269 insertions(+), 16 deletions(-) diff --git a/backend/src/Edna/DB/Integration.hs b/backend/src/Edna/DB/Integration.hs index 54fc548c..b9f11864 100644 --- a/backend/src/Edna/DB/Integration.hs +++ b/backend/src/Edna/DB/Integration.hs @@ -15,10 +15,12 @@ module Edna.DB.Integration , runDeleteReturningList' , runSelectReturningOne' , runSelectReturningList' + , runSelectReturningSet ) where import Universum +import qualified Data.Set as Set import qualified Database.Beam.Postgres.Conduit as C import Database.Beam.Backend.SQL.BeamExtensions (runInsertReturningList) @@ -96,3 +98,10 @@ runSelectReturningOne' = runPg . runSelectReturningOne runSelectReturningList' :: FromBackendRow Postgres a => SqlSelect Postgres a -> Edna [a] runSelectReturningList' = runPg . runSelectReturningList + +-- | Run @SELECT@ and convert its result into a set. Conversion happens in Haskell. +-- Note that all duplicates are silently removed and items are sorted. +runSelectReturningSet :: + (Ord a, FromBackendRow Postgres a) => + SqlSelect Postgres a -> Edna (Set a) +runSelectReturningSet = fmap Set.fromList . runSelectReturningList' diff --git a/backend/src/Edna/Dashboard/DB/Query.hs b/backend/src/Edna/Dashboard/DB/Query.hs index f056e2ff..04e220a7 100644 --- a/backend/src/Edna/Dashboard/DB/Query.hs +++ b/backend/src/Edna/Dashboard/DB/Query.hs @@ -10,6 +10,9 @@ module Edna.Dashboard.DB.Query , setIsSuspiciousSubExperiment , deleteSubExperiment , getExperiments + , getMatchedProjects + , getMatchedCompounds + , getMatchedTargets , getDescriptionAndMetadata , getFileNameAndBlob , getSubExperiment @@ -34,14 +37,16 @@ import Servant.Util.Combinators.Sorting.Backend (fieldSort) import Edna.Analysis.FourPL (AnalysisResult, Params4PL(..)) import Edna.DB.Integration - (runDeleteReturningList', runSelectReturningList', runSelectReturningOne', runUpdate') + (runDeleteReturningList', runSelectReturningList', runSelectReturningOne', runSelectReturningSet, + runUpdate') import Edna.DB.Schema (EdnaSchema(..), ednaSchema) import Edna.DB.Util (groupAndPaginate, sortingSpecWithId) import Edna.Dashboard.DB.Schema import Edna.Dashboard.Web.Types (ExperimentResp(..), ExperimentSortingSpec) import Edna.ExperimentReader.Types (FileMetadata) import Edna.Library.DB.Schema - (CompoundRec, CompoundT(..), TargetRec, TargetT(..), TestMethodologyRec, TestMethodologyT(..)) + (CompoundRec, CompoundT(..), ProjectT(..), TargetRec, TargetT(..), TestMethodologyRec, + TestMethodologyT(..)) import Edna.Orphans () import Edna.Setup (Edna) import Edna.Upload.DB.Schema (ExperimentFileT(..)) @@ -200,6 +205,68 @@ getExperiments mProj mComp mTarget sorting pagination = Nothing -> error $ "can't find primary sub-experiment: " <> pretty primary Just (_, PgJSON analysisResult) -> p4plC <$> analysisResult +-- | Get names of all projects with experiments optionally filtered by +-- compound and target. +getMatchedProjects :: Maybe CompoundId -> Maybe TargetId -> Edna (Set Text) +getMatchedProjects mComp mTarget = + runSelectReturningSet $ select $ do + experiment <- all_ $ esExperiment ednaSchema + filterByTarget mTarget experiment + filterByCompound mComp experiment + + experimentFile <- join_ (esExperimentFile ednaSchema) $ \ef -> + eExperimentFileId experiment ==. cast_ (efExperimentFileId ef) int + + project <- join_ (esProject ednaSchema) $ \p -> + efProjectId experimentFile ==. cast_ (pProjectId p) int + return (pName project) + +-- | Get names of all compounds from experiments optionally filtered by +-- project and target. +getMatchedCompounds :: Maybe ProjectId -> Maybe TargetId -> Edna (Set Text) +getMatchedCompounds mProj mTarget = + runSelectReturningSet $ select $ do + experiment <- all_ $ esExperiment ednaSchema + filterByProject mProj experiment + filterByTarget mTarget experiment + + compound <- join_ (esCompound ednaSchema) $ \comp -> + cast_ (cCompoundId comp) int ==. eCompoundId experiment + return (cName compound) + +-- | Get names of all targets from experiments optionally filtered by +-- project and compound. +getMatchedTargets :: Maybe ProjectId -> Maybe CompoundId -> Edna (Set Text) +getMatchedTargets mProj mComp = + runSelectReturningSet $ select $ do + experiment <- all_ $ esExperiment ednaSchema + filterByProject mProj experiment + filterByCompound mComp experiment + + target <- join_ (esTarget ednaSchema) $ \tar -> + cast_ (tTargetId tar) int ==. eTargetId experiment + return (tName target) + +filterByProject :: + Maybe ProjectId -> + ExperimentT (QExpr Postgres s) -> Q Postgres EdnaSchema s () +filterByProject mProj experiment = whenJust mProj $ \(SqlId projId) -> do + experimentFile <- join_ (esExperimentFile ednaSchema) $ \ef -> + eExperimentFileId experiment ==. cast_ (efExperimentFileId ef) int + guard_ (efProjectId experimentFile ==. val_ projId) + +filterByCompound :: + Maybe CompoundId -> + ExperimentT (QExpr Postgres s) -> Q Postgres EdnaSchema s () +filterByCompound mComp experiment = whenJust mComp $ \(SqlId compId) -> + guard_ (eCompoundId experiment ==. val_ compId) + +filterByTarget :: + Maybe TargetId -> + ExperimentT (QExpr Postgres s) -> Q Postgres EdnaSchema s () +filterByTarget mTarget experiment = whenJust mTarget $ \(SqlId targetId) -> + guard_ (eTargetId experiment ==. val_ targetId) + -- | Get description and metadata of experiment data file storing experiment -- with this ID. getDescriptionAndMetadata :: diff --git a/backend/src/Edna/Dashboard/Service.hs b/backend/src/Edna/Dashboard/Service.hs index 0375ea65..a0d0561d 100644 --- a/backend/src/Edna/Dashboard/Service.hs +++ b/backend/src/Edna/Dashboard/Service.hs @@ -13,6 +13,8 @@ module Edna.Dashboard.Service , newSubExperiment , analyseNewSubExperiment , getExperiments + , getExperimentsSummary + , getActiveProjectNames , getExperimentMetadata , getExperimentFile , getSubExperiment @@ -30,6 +32,7 @@ import Servant.API (NoContent(..)) import Servant.Util (PaginationSpec) import qualified Edna.Dashboard.DB.Query as Q +import qualified Edna.Library.DB.Query as LQ import qualified Edna.Upload.DB.Query as UQ import Edna.Analysis.FourPL (AnalysisResult, analyse4PLOne) @@ -38,7 +41,7 @@ import Edna.Dashboard.DB.Schema (MeasurementT(..), SubExperimentRec, SubExperime import Edna.Dashboard.Error (DashboardError(..)) import Edna.Dashboard.Web.Types (ExperimentFileBlob(..), ExperimentMetadata(..), ExperimentSortingSpec, ExperimentsResp(..), - MeasurementResp(..), NewSubExperimentReq(..), SubExperimentResp(..)) + ExperimentsSummaryResp(..), MeasurementResp(..), NewSubExperimentReq(..), SubExperimentResp(..)) import Edna.ExperimentReader.Types (FileMetadata(..)) import Edna.Logging (logMessage) import Edna.Setup (Edna) @@ -141,6 +144,35 @@ getExperiments mProj mComp mTarget sorting pagination = unwrapResult :: PgJSON AnalysisResult -> AnalysisResult unwrapResult (PgJSON res) = res +-- | Get short data about all experiments using 3 optional filters: by project ID, +-- compound ID and target ID. See description of 'ExperimentsSummaryResp' for details. +getExperimentsSummary :: Maybe ProjectId -> Maybe CompoundId -> Maybe TargetId -> + Edna ExperimentsSummaryResp +getExperimentsSummary mProj mComp mTarget = do + -- Getting all projects in the system would be wrong because there can be + -- empty ones. + esrMatchedProjects <- Q.getMatchedProjects mComp mTarget + esrMatchedCompounds <- + getMatchedOrAll mProj mTarget Q.getMatchedCompounds LQ.getCompoundNames + esrMatchedTargets <- + getMatchedOrAll mProj mComp Q.getMatchedTargets LQ.getTargetNames + return ExperimentsSummaryResp {..} + where + -- If at least one filter is provided, we call @getMatched@. + -- Otherwise we call @getAll@ which gets all items in the system. + getMatchedOrAll :: + Maybe filter1 -> Maybe filter2 -> + (Maybe filter1 -> Maybe filter2 -> Edna res) -> + Edna res -> + Edna res + getMatchedOrAll filter1 filter2 getMatched getAll + | isNothing filter1 && isNothing filter2 = getAll + | otherwise = getMatched filter1 filter2 + +-- | Get names of all projects with at least one experiment. +getActiveProjectNames :: Edna (Set Text) +getActiveProjectNames = Q.getMatchedProjects Nothing Nothing + -- | Get all metadata about experiment data file containing experiment -- with this ID. "All" metadata means metadata from the file itself -- along with description provided by the user. diff --git a/backend/src/Edna/Dashboard/Web/API.hs b/backend/src/Edna/Dashboard/Web/API.hs index e9d92bcb..f0435532 100644 --- a/backend/src/Edna/Dashboard/Web/API.hs +++ b/backend/src/Edna/Dashboard/Web/API.hs @@ -23,8 +23,8 @@ import Servant.Util (PaginationParams, SortingParamsOf) import Edna.Analysis.FourPL (AnalysisResult) import Edna.Dashboard.Service (analyseNewSubExperiment, deleteSubExperiment, getExperimentFile, getExperimentMetadata, - getExperiments, getMeasurements, getSubExperiment, makePrimarySubExperiment, newSubExperiment, - setIsSuspiciousSubExperiment, setNameSubExperiment) + getExperiments, getExperimentsSummary, getMeasurements, getSubExperiment, + makePrimarySubExperiment, newSubExperiment, setIsSuspiciousSubExperiment, setNameSubExperiment) import Edna.Dashboard.Web.Types import Edna.Setup (Edna) import Edna.Util (CompoundId, ExperimentId, IdType(..), ProjectId, SubExperimentId, TargetId) @@ -96,6 +96,16 @@ data DashboardEndpoints route = DashboardEndpoints :> PaginationParams :> Get '[JSON] ExperimentsResp + , -- | Get summary of all experiments + deGetExperimentsSummary :: route + :- "experiments" + :> "summary" + :> Summary "Get summary of all experiments" + :> QueryParam "projectId" ProjectId + :> QueryParam "compoundId" CompoundId + :> QueryParam "targetId" TargetId + :> Get '[JSON] ExperimentsSummaryResp + , -- | Get experiment's metadata by ID deGetExperimentMetadata :: route :- "experiment" @@ -140,6 +150,7 @@ dashboardEndpoints = genericServerT DashboardEndpoints , deNewSubExp = newSubExperiment , deAnalyseNewSubExp = fmap snd ... analyseNewSubExperiment , deGetExperiments = getExperiments + , deGetExperimentsSummary = getExperimentsSummary , deGetExperimentMetadata = getExperimentMetadata , deGetExperimentFile = \i -> getExperimentFile i <&> \(name, blob) -> addHeader ("attachment;filename=" <> name) blob diff --git a/backend/src/Edna/Dashboard/Web/Types.hs b/backend/src/Edna/Dashboard/Web/Types.hs index 0dd4e08a..a0a07997 100644 --- a/backend/src/Edna/Dashboard/Web/Types.hs +++ b/backend/src/Edna/Dashboard/Web/Types.hs @@ -9,6 +9,7 @@ module Edna.Dashboard.Web.Types , ExperimentsResp (..) , ExperimentResp (..) , ExperimentSortingSpec + , ExperimentsSummaryResp (..) , SubExperimentResp (..) , MeasurementResp (..) , ExperimentMetadata (..) @@ -48,7 +49,7 @@ instance Buildable NewSubExperimentReq where "new sub-experiment name: " +| nserName |+ ", changes: " +| toList nserChanges |+ "" --- | Experiment as response from the server. +-- | Experiments as response from the server. newtype ExperimentsResp = ExperimentsResp { erExperiments :: [WithId 'ExperimentId ExperimentResp] } deriving stock (Generic, Show) @@ -115,6 +116,44 @@ type instance SortingParamTypesOf ExperimentResp = type ExperimentSortingSpec = SortingSpec (SortingParamTypesOf ExperimentResp) +-- | Summary of experiments matching given search. We use it to show selectors. +data ExperimentsSummaryResp = ExperimentsSummaryResp + { esrMatchedProjects :: Set Text + -- ^ If target and/or compound filter is specified, these are all projects + -- where specified target and/or compound is used. + -- Otherwise this list contains all projects. + , esrMatchedCompounds :: Set Text + -- ^ If target and/or project filter is specified, these are all compounds + -- used in specified project and/or with specified target. + -- Otherwise this list contains all compounds. + , esrMatchedTargets :: Set Text + -- ^ If compound and/or project filter is specified, these are all targets + -- used in specified project and/or with specified compound. + -- Otherwise this list contains all targets. + } deriving stock (Generic, Show, Eq) + +instance Buildable ExperimentsSummaryResp where + build = genericF + +-- | Temporary newtype we use to provide @instance Buildable (ForResponseLog Text)@. +-- Probably will disappear when we introduce @Name@ type. +newtype BuildableResponseLog a = BuildableResponseLog a + +instance Buildable a => Buildable (ForResponseLog (BuildableResponseLog a)) where + build (ForResponseLog (BuildableResponseLog a)) = build a + +instance Buildable (ForResponseLog ExperimentsSummaryResp) where + build (ForResponseLog (ExperimentsSummaryResp projects compounds targets)) = + "ExperimentsSummary:\n" <> + " matched projects:\n" <> + buildListForResponse (take 12) (wrap projects) <> + " matched compounds:\n" <> + buildListForResponse (take 12) (wrap compounds) <> + " matched targets:\n" <> + buildListForResponse (take 12) (wrap targets) + where + wrap = ForResponseLog . map BuildableResponseLog . toList + -- | SubExperiment as response from the server. data SubExperimentResp = SubExperimentResp { serName :: Text @@ -198,6 +237,7 @@ instance Buildable (ForResponseLog $ deriveJSON ednaAesonWebOptions ''NewSubExperimentReq deriveToJSON ednaAesonWebOptions ''ExperimentsResp deriveToJSON ednaAesonWebOptions ''ExperimentResp +deriveToJSON ednaAesonWebOptions ''ExperimentsSummaryResp deriveToJSON ednaAesonWebOptions ''SubExperimentResp deriveToJSON ednaAesonWebOptions ''MeasurementResp deriveToJSON ednaAesonWebOptions ''ExperimentMetadata @@ -208,6 +248,9 @@ instance ToSchema NewSubExperimentReq where instance ToSchema ExperimentsResp where declareNamedSchema = gDeclareNamedSchema +instance ToSchema ExperimentsSummaryResp where + declareNamedSchema = gDeclareNamedSchema + instance ToSchema ExperimentResp where declareNamedSchema = gDeclareNamedSchema diff --git a/backend/src/Edna/Library/DB/Query.hs b/backend/src/Edna/Library/DB/Query.hs index 1bbc7ffa..f5873a42 100644 --- a/backend/src/Edna/Library/DB/Query.hs +++ b/backend/src/Edna/Library/DB/Query.hs @@ -9,8 +9,10 @@ module Edna.Library.DB.Query ( getTargetById , getTargets + , getTargetNames , getCompoundById , getCompounds + , getCompoundNames , editCompoundChemSoft , editCompoundMde , getMethodologyById @@ -47,7 +49,7 @@ import Servant.Util.Combinators.Sorting.Backend (fieldSort) import Edna.DB.Integration (runDeleteReturningList', runInsert', runInsertReturningOne', runSelectReturningList', - runSelectReturningOne', runUpdate') + runSelectReturningOne', runSelectReturningSet, runUpdate') import Edna.DB.Schema (EdnaSchema(..), ednaSchema) import Edna.DB.Util (groupAndPaginate, sortingSpecWithId) import Edna.Dashboard.DB.Schema (ExperimentT(..)) @@ -128,6 +130,11 @@ getTargetByName name = runSelectReturningOne' $ select $ do guard_ (LDB.tName targets ==. val_ name) pure targets +-- | Get names of all targets in the system. +getTargetNames :: Edna (Set Text) +getTargetNames = runSelectReturningSet $ select $ + tName <$> all_ (esTarget ednaSchema) + -- | Insert target with given name and return its DB value. If target with this name -- already exists do nothing and simply return it. insertTarget :: Text -> Edna TargetRec @@ -161,6 +168,11 @@ getCompounds sorting pagination = runSelectReturningList' $ select $ fieldSort @"additionDate" cAdditionDate .*. HNil +-- | Get names of all compounds in the system. +getCompoundNames :: Edna (Set Text) +getCompoundNames = runSelectReturningSet $ select $ + cName <$> all_ (esCompound ednaSchema) + -- | Edit ChemSoft link of a given compound editCompoundChemSoft :: CompoundId -> Text -> Edna () editCompoundChemSoft (SqlId compoundId) link = runUpdate' $ update @@ -339,7 +351,7 @@ projectsWithCompounds projectIdEither = fieldSort @"lastUpdate" pLastUpdate .*. HNil --- | Insert project and return its DB value +-- | Insert project and return its DB value. -- Fails if project with this name already exists insertProject :: ProjectReq -> Edna ProjectRec insertProject ProjectReq{..} = runInsertReturningOne' $ diff --git a/backend/src/Edna/Library/Service.hs b/backend/src/Edna/Library/Service.hs index 6ee90005..ad3413e5 100644 --- a/backend/src/Edna/Library/Service.hs +++ b/backend/src/Edna/Library/Service.hs @@ -21,6 +21,10 @@ module Edna.Library.Service , getProjects , addProject , updateProject + + -- * Re-export some queries as is + , Q.getTargetNames + , Q.getCompoundNames ) where import Universum diff --git a/backend/test/Test/DashboardSpec.hs b/backend/test/Test/DashboardSpec.hs index 9aa03402..28a0f87c 100644 --- a/backend/test/Test/DashboardSpec.hs +++ b/backend/test/Test/DashboardSpec.hs @@ -26,15 +26,15 @@ import qualified Edna.Library.Service as Library import Edna.Analysis.FourPL (Params4PL(..), analyse4PLOne) import Edna.Dashboard.Error (DashboardError(..)) import Edna.Dashboard.Service - (analyseNewSubExperiment, deleteSubExperiment, getExperimentFile, getExperimentMetadata, - getExperiments, getMeasurements, getSubExperiment, makePrimarySubExperiment, newSubExperiment, - setIsSuspiciousSubExperiment, setNameSubExperiment) + (analyseNewSubExperiment, deleteSubExperiment, getActiveProjectNames, getExperimentFile, + getExperimentMetadata, getExperiments, getExperimentsSummary, getMeasurements, getSubExperiment, + makePrimarySubExperiment, newSubExperiment, setIsSuspiciousSubExperiment, setNameSubExperiment) import Edna.Dashboard.Web.Types (ExperimentFileBlob(..), ExperimentMetadata(..), ExperimentResp(..), ExperimentsResp(..), - MeasurementResp(..), NewSubExperimentReq(..), SubExperimentResp(..)) + ExperimentsSummaryResp(..), MeasurementResp(..), NewSubExperimentReq(..), SubExperimentResp(..)) import Edna.ExperimentReader.Types (FileMetadata(unFileMetadata), Measurement(..), measurementToPairMaybe) -import Edna.Library.Web.Types (MethodologyReq(..)) +import Edna.Library.Web.Types (MethodologyReq(..), ProjectReq(..)) import Edna.Setup (EdnaContext) import Edna.Util (ExperimentId, IdType(..), SqlId(..), SubExperimentId) import Edna.Web.Types (WithId(..)) @@ -123,6 +123,7 @@ spec = withContext $ do where addSampleData = do addSampleProjects + void $ Library.addProject (ProjectReq "unused project" Nothing) addSampleMethodologies toDeleteId <- wiId <$> Library.addMethodology (MethodologyReq "toDelete" Nothing Nothing) uploadFileTest (SqlId 1) (SqlId 1) sampleFile @@ -224,6 +225,54 @@ gettersSpec = do descByTarget `shouldBe` paginateAndGetIds (sortWith getTargetName allExperiments) + describe "getExperimentsSummary" $ do + let + projectId = SqlId 1 + compoundId = SqlId 1 + targetId = SqlId 1 + it "returns all items with no filters" $ runTestEdna $ do + allProjects <- getActiveProjectNames + allCompounds <- Library.getCompoundNames + allTargets <- Library.getTargetNames + ExperimentsSummaryResp {..} <- + getExperimentsSummary Nothing Nothing Nothing + liftIO $ do + esrMatchedProjects `shouldBe` allProjects + esrMatchedCompounds `shouldBe` allCompounds + esrMatchedTargets `shouldBe` allTargets + it "filters by project" $ runTestEdna $ do + ExperimentsSummaryResp {..} <- + getExperimentsSummary (Just projectId) Nothing Nothing + liftIO $ do + toList esrMatchedProjects `shouldBe` [projectName1, projectName2] + toList esrMatchedCompounds `shouldBe` + [compoundName1, compoundName2, compoundName3, compoundName4] + toList esrMatchedTargets `shouldBe` + [targetName1, targetName2, targetName3] + it "filters by compound" $ runTestEdna $ do + ExperimentsSummaryResp {..} <- + getExperimentsSummary Nothing (Just compoundId) Nothing + liftIO $ do + toList esrMatchedProjects `shouldBe` [projectName1, projectName2] + toList esrMatchedCompounds `shouldBe` + [compoundName1, compoundName2, compoundName3, compoundName4] + toList esrMatchedTargets `shouldBe` + [targetName1, targetName3] + it "filters by target" $ runTestEdna $ do + ExperimentsSummaryResp {..} <- + getExperimentsSummary Nothing Nothing (Just targetId) + liftIO $ do + toList esrMatchedProjects `shouldBe` [projectName1, projectName2] + toList esrMatchedCompounds `shouldBe` + [compoundName1, compoundName2, compoundName3] + toList esrMatchedTargets `shouldBe` + [targetName1, targetName2, targetName3] + + describe "getActiveProjectNames" $ do + it "returns names of all projects with experiments" $ runTestEdna $ do + names <- getActiveProjectNames + liftIO $ toList names `shouldBe` [projectName1, projectName2] + describe "getExperimentMetadata" $ do it "returns correct metadata for all known experiments" $ runTestEdna $ do forM_ validExperimentIds $ \expId -> do @@ -234,6 +283,7 @@ gettersSpec = do it "fails for unknown experiment" $ \ctx -> do runRIO ctx (getExperimentMetadata unknownSqlId) `shouldThrow` (== DEExperimentNotFound unknownSqlId) + describe "getExperimentFile" $ do it "returns correct file name and blob for all known experiments" $ runTestEdna $ do forM_ validExperimentIds $ \expId -> do @@ -244,6 +294,7 @@ gettersSpec = do it "fails for unknown experiment" $ \ctx -> do runRIO ctx (getExperimentFile unknownSqlId) `shouldThrow` (== DEExperimentNotFound unknownSqlId) + describe "getSubExperiment" $ do it "returns correct results for sub-experiments 1-6" $ runTestEdna $ do resps <- forM validSubExperimentIds $ \subExpId -> do @@ -256,6 +307,7 @@ gettersSpec = do it "fails for unknown sub-experiment" $ \ctx -> do runRIO ctx (getSubExperiment unknownSqlId) `shouldThrow` (== DESubExperimentNotFound unknownSqlId) + describe "getMeasurements" $ do it "returns correct measurements for sub-experiments 13-19" $ runTestEdna $ do [ measurements1 diff --git a/backend/test/Test/Gen.hs b/backend/test/Test/Gen.hs index 35347112..c75057e6 100644 --- a/backend/test/Test/Gen.hs +++ b/backend/test/Test/Gen.hs @@ -25,6 +25,7 @@ module Test.Gen , genCompoundResp , genTargetResp , genExperimentsResp + , genExperimentsSummaryResp , genExperimentResp , genSubExperimentResp , genMeasurementResp @@ -46,6 +47,7 @@ import Universum import qualified Data.ByteString.Lazy as BL import qualified Data.HashSet as HS +import qualified Data.Set as Set import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Gen.QuickCheck as HQC import qualified Hedgehog.Range as Range @@ -167,6 +169,14 @@ genExperimentsResp :: MonadGen m => m ExperimentsResp genExperimentsResp = ExperimentsResp <$> Gen.list (Range.linear 0 5) (genWithId genExperimentResp) +genExperimentsSummaryResp :: MonadGen m => m ExperimentsSummaryResp +genExperimentsSummaryResp = do + let genNames = Set.fromList <$> Gen.list (Range.linear 0 10) genName + esrMatchedProjects <- genNames + esrMatchedCompounds <- genNames + esrMatchedTargets <- genNames + return ExperimentsSummaryResp {..} + genExperimentResp :: MonadGen m => m ExperimentResp genExperimentResp = do erProject <- genSqlId @@ -314,6 +324,9 @@ instance Arbitrary NewSubExperimentReq where instance Arbitrary ExperimentsResp where arbitrary = hedgehog genExperimentsResp +instance Arbitrary ExperimentsSummaryResp where + arbitrary = hedgehog genExperimentsSummaryResp + instance Arbitrary ExperimentResp where arbitrary = hedgehog genExperimentResp diff --git a/backend/test/Test/LibrarySpec.hs b/backend/test/Test/LibrarySpec.hs index 6ac22143..3689c212 100644 --- a/backend/test/Test/LibrarySpec.hs +++ b/backend/test/Test/LibrarySpec.hs @@ -22,9 +22,9 @@ import Test.Hspec import Edna.Library.Error (LibraryError(..)) import Edna.Library.Service - (addMethodology, addProject, deleteMethodology, editChemSoft, editMde, getCompound, getCompounds, - getMethodologies, getMethodology, getProject, getProjects, getTarget, getTargets, - updateMethodology, updateProject) + (addMethodology, addProject, deleteMethodology, editChemSoft, editMde, getCompound, + getCompoundNames, getCompounds, getMethodologies, getMethodology, getProject, getProjects, + getTarget, getTargetNames, getTargets, updateMethodology, updateProject) import Edna.Library.Web.Types (CompoundResp(..), MethodologyReq(..), MethodologyResp(..), ProjectReq(..), ProjectResp(..), TargetResp(..)) @@ -82,6 +82,11 @@ gettersSpec = do -- have equal addition date, but different IDs checkTargets (Just (compare `on` (Down . view _1))) (Just paginationDesc) targetsDescDate + describe "getTargetNames" $ do + it "successfully gets names of all targets" $ runTestEdna $ do + names <- getTargetNames + liftIO $ toList names `shouldBe` map (view $ _2 . _1) allExpectedTargets + describe "getCompound" $ do it "successfully gets known compounds one by one" $ runTestEdna $ do compounds <- mapM getCompound compoundIds @@ -104,6 +109,11 @@ gettersSpec = do (mkPagination paginationDesc) checkCompounds (Just (compare `on` (Down . snd))) (Just paginationDesc) compoundsDesc + describe "getCompoundNames" $ do + it "successfully gets names of all compounds" $ runTestEdna $ do + names <- getCompoundNames + liftIO $ toList names `shouldBe` map snd allExpectedCompounds + describe "getMethodology" $ do it "successfully gets known methodologies one by one" $ runTestEdna $ do methodologies <- mapM getMethodology methodologyIds From ea9e00b49287f8ea2aba487e4aaecfb499a116c9 Mon Sep 17 00:00:00 2001 From: Ivan Gromakovskii Date: Fri, 7 May 2021 16:06:53 +0300 Subject: [PATCH 2/2] Add "names" getters to edna-server Problem: sometimes we need to know names of all entities of certain, e. g. all projects on upload page, so that the user can select a project. Currently it can be done by calling `/projects`, but it's a bit expensive because it also gets more data than necessary. Solution: add new endpoints to get names of all entities. For projects we have 2 such getters: all projects in the system (including projects without any experiments) and only projects with experiments. All projects in the system are needed for the Upload page and all projects with experiments are needed for the Dashboard page. --- backend/src/Edna/Dashboard/Web/API.hs | 15 +++++++-- backend/src/Edna/Dashboard/Web/Types.hs | 11 ++----- backend/src/Edna/Library/DB/Query.hs | 12 ++++++++ backend/src/Edna/Library/Service.hs | 2 ++ backend/src/Edna/Library/Web/API.hs | 41 ++++++++++++++++++++++--- backend/src/Edna/Util.hs | 10 +++++- backend/src/Edna/Web/Types.hs | 21 ++++++++++++- backend/test/Test/Gen.hs | 7 +++++ 8 files changed, 101 insertions(+), 18 deletions(-) diff --git a/backend/src/Edna/Dashboard/Web/API.hs b/backend/src/Edna/Dashboard/Web/API.hs index f0435532..e4266d9a 100644 --- a/backend/src/Edna/Dashboard/Web/API.hs +++ b/backend/src/Edna/Dashboard/Web/API.hs @@ -22,13 +22,13 @@ import Servant.Util (PaginationParams, SortingParamsOf) import Edna.Analysis.FourPL (AnalysisResult) import Edna.Dashboard.Service - (analyseNewSubExperiment, deleteSubExperiment, getExperimentFile, getExperimentMetadata, - getExperiments, getExperimentsSummary, getMeasurements, getSubExperiment, + (analyseNewSubExperiment, deleteSubExperiment, getActiveProjectNames, getExperimentFile, + getExperimentMetadata, getExperiments, getExperimentsSummary, getMeasurements, getSubExperiment, makePrimarySubExperiment, newSubExperiment, setIsSuspiciousSubExperiment, setNameSubExperiment) import Edna.Dashboard.Web.Types import Edna.Setup (Edna) import Edna.Util (CompoundId, ExperimentId, IdType(..), ProjectId, SubExperimentId, TargetId) -import Edna.Web.Types (WithId) +import Edna.Web.Types (NamesSet(..), WithId) -- | Endpoints related to projects. data DashboardEndpoints route = DashboardEndpoints @@ -137,6 +137,14 @@ data DashboardEndpoints route = DashboardEndpoints :> Capture "subExperimentId" SubExperimentId :> "measurements" :> Get '[JSON] [WithId 'MeasurementId MeasurementResp] + + , -- | Get names of all projects with experiments. + deGetActiveProjectNames :: route + :- "projects" + :> "names" + :> "active" + :> Summary "Get names of all projects with experiments" + :> Get '[JSON] NamesSet } deriving stock (Generic) type DashboardAPI = ToServant DashboardEndpoints AsApi @@ -156,4 +164,5 @@ dashboardEndpoints = genericServerT DashboardEndpoints \(name, blob) -> addHeader ("attachment;filename=" <> name) blob , deGetSubExperiment = getSubExperiment , deGetMeasurements = getMeasurements + , deGetActiveProjectNames = NamesSet <$> getActiveProjectNames } diff --git a/backend/src/Edna/Dashboard/Web/Types.hs b/backend/src/Edna/Dashboard/Web/Types.hs index a0a07997..2a403ce2 100644 --- a/backend/src/Edna/Dashboard/Web/Types.hs +++ b/backend/src/Edna/Dashboard/Web/Types.hs @@ -30,8 +30,8 @@ import Servant.Util.Combinators.Logging (ForResponseLog(..), buildForResponse, b import Edna.Analysis.FourPL (AnalysisResult) import Edna.Util - (CompoundId, IdType(..), MeasurementId, MethodologyId, ProjectId, SubExperimentId, TargetId, - ednaAesonWebOptions, gDeclareNamedSchema, unSqlId) + (BuildableResponseLog(..), CompoundId, IdType(..), MeasurementId, MethodologyId, ProjectId, + SubExperimentId, TargetId, ednaAesonWebOptions, gDeclareNamedSchema, unSqlId) import Edna.Web.Types (WithId) -- | Data submitted in body to create a new sub-experiment. @@ -135,13 +135,6 @@ data ExperimentsSummaryResp = ExperimentsSummaryResp instance Buildable ExperimentsSummaryResp where build = genericF --- | Temporary newtype we use to provide @instance Buildable (ForResponseLog Text)@. --- Probably will disappear when we introduce @Name@ type. -newtype BuildableResponseLog a = BuildableResponseLog a - -instance Buildable a => Buildable (ForResponseLog (BuildableResponseLog a)) where - build (ForResponseLog (BuildableResponseLog a)) = build a - instance Buildable (ForResponseLog ExperimentsSummaryResp) where build (ForResponseLog (ExperimentsSummaryResp projects compounds targets)) = "ExperimentsSummary:\n" <> diff --git a/backend/src/Edna/Library/DB/Query.hs b/backend/src/Edna/Library/DB/Query.hs index f5873a42..cbc79abd 100644 --- a/backend/src/Edna/Library/DB/Query.hs +++ b/backend/src/Edna/Library/DB/Query.hs @@ -18,6 +18,7 @@ module Edna.Library.DB.Query , getMethodologyById , getMethodologyByName , getMethodologies + , getMethodologyNames , deleteMethodology , insertMethodology , updateMethodology @@ -25,6 +26,7 @@ module Edna.Library.DB.Query , getProjectByName , getProjectWithCompoundsById , getProjectsWithCompounds + , getProjectNames , insertProject , updateProject , touchProject @@ -254,6 +256,11 @@ getMethodology' eMethodologyId = fieldSort @"name" tmName .*. HNil +-- | Get names of all methodologies in the system. +getMethodologyNames :: Edna (Set Text) +getMethodologyNames = runSelectReturningSet $ select $ + tmName <$> all_ (esTestMethodology ednaSchema) + -- | Insert methodology and return its DB value. -- Fails if methodology with this name already exists insertMethodology :: MethodologyReq -> Edna TestMethodologyRec @@ -351,6 +358,11 @@ projectsWithCompounds projectIdEither = fieldSort @"lastUpdate" pLastUpdate .*. HNil +-- | Get names of all projects in the system. +getProjectNames :: Edna (Set Text) +getProjectNames = runSelectReturningSet $ select $ + pName <$> all_ (esProject ednaSchema) + -- | Insert project and return its DB value. -- Fails if project with this name already exists insertProject :: ProjectReq -> Edna ProjectRec diff --git a/backend/src/Edna/Library/Service.hs b/backend/src/Edna/Library/Service.hs index ad3413e5..f9ba8717 100644 --- a/backend/src/Edna/Library/Service.hs +++ b/backend/src/Edna/Library/Service.hs @@ -25,6 +25,8 @@ module Edna.Library.Service -- * Re-export some queries as is , Q.getTargetNames , Q.getCompoundNames + , Q.getMethodologyNames + , Q.getProjectNames ) where import Universum diff --git a/backend/src/Edna/Library/Web/API.hs b/backend/src/Edna/Library/Web/API.hs index b28f6ed2..7baae4ea 100644 --- a/backend/src/Edna/Library/Web/API.hs +++ b/backend/src/Edna/Library/Web/API.hs @@ -31,14 +31,15 @@ import Servant.Server.Generic (AsServerT, genericServerT) import Servant.Util (PaginationParams, SortingParamsOf) import Edna.Library.Service - (addMethodology, addProject, deleteMethodology, editChemSoft, editMde, getCompound, getCompounds, - getMethodologies, getMethodology, getProject, getProjects, getTarget, getTargets, - updateMethodology, updateProject) + (addMethodology, addProject, deleteMethodology, editChemSoft, editMde, getCompound, + getCompoundNames, getCompounds, getMethodologies, getMethodology, getMethodologyNames, getProject, + getProjectNames, getProjects, getTarget, getTargetNames, getTargets, updateMethodology, + updateProject) import Edna.Library.Web.Types (CompoundResp, MethodologyReq, MethodologyResp, ProjectReq, ProjectResp, TargetResp) import Edna.Setup (Edna) import Edna.Util (IdType(..), MethodologyId, SqlId(..)) -import Edna.Web.Types (URI, WithId) +import Edna.Web.Types (NamesSet(..), URI, WithId) -- | Endpoints related to projects. data ProjectEndpoints route = ProjectEndpoints @@ -65,6 +66,13 @@ data ProjectEndpoints route = ProjectEndpoints :> PaginationParams :> Get '[JSON] [WithId 'ProjectId ProjectResp] + , -- | Get names of all known projects + peGetProjectNames :: route + :- "projects" + :> "names" + :> Summary "Get names of all known projects" + :> Get '[JSON] NamesSet + , -- | Get project data by ID peGetProject :: route :- "project" @@ -80,6 +88,7 @@ projectEndpoints = genericServerT ProjectEndpoints { peAddProject = addProject , peEditProject = updateProject , peGetProjects = getProjects + , peGetProjectNames = NamesSet <$> getProjectNames , peGetProject = getProject } @@ -115,6 +124,13 @@ data MethodologyEndpoints route = MethodologyEndpoints :> PaginationParams :> Get '[JSON] [WithId 'MethodologyId MethodologyResp] + , -- | Get names of all known methodologies + meGetMethodologyNames :: route + :- "methodologies" + :> "names" + :> Summary "Get names of all known methodologies" + :> Get '[JSON] NamesSet + , -- | Get methodology data by ID meGetMethodology :: route :- "methodology" @@ -131,6 +147,7 @@ methodologyEndpoints = genericServerT MethodologyEndpoints , meEditMethodology = updateMethodology , meDeleteMethodology = deleteMethodology , meGetMethodologies = getMethodologies + , meGetMethodologyNames = NamesSet <$> getMethodologyNames , meGetMethodology = getMethodology } @@ -144,6 +161,13 @@ data TargetEndpoints route = TargetEndpoints :> PaginationParams :> Get '[JSON] [WithId 'TargetId TargetResp] + , -- | Get names of all known targets + teGetTargetNames :: route + :- "targets" + :> "names" + :> Summary "Get names of all known targets" + :> Get '[JSON] NamesSet + , -- | Get target data by ID teGetTarget :: route :- "target" @@ -158,6 +182,7 @@ targetEndpoints :: ToServant TargetEndpoints (AsServerT Edna) targetEndpoints = genericServerT TargetEndpoints { teGetTargets = getTargets , teGetTarget = getTarget + , teGetTargetNames = NamesSet <$> getTargetNames } -- | Endpoints related to compounds. @@ -188,6 +213,13 @@ data CompoundEndpoints route = CompoundEndpoints :> PaginationParams :> Get '[JSON] [WithId 'CompoundId CompoundResp] + , -- | Get names of all known compounds + ceGetCompoundNames :: route + :- "compounds" + :> "names" + :> Summary "Get names of all known compounds" + :> Get '[JSON] NamesSet + , -- | Get compound data by ID ceGetCompound :: route :- "compound" @@ -203,5 +235,6 @@ compoundEndpoints = genericServerT CompoundEndpoints { ceEditChemSoft = editChemSoft , ceEditMde = editMde , ceGetCompounds = getCompounds + , ceGetCompoundNames = NamesSet <$> getCompoundNames , ceGetCompound = getCompound } diff --git a/backend/src/Edna/Util.hs b/backend/src/Edna/Util.hs index 1ed84ae7..ad22d850 100644 --- a/backend/src/Edna/Util.hs +++ b/backend/src/Edna/Util.hs @@ -10,6 +10,7 @@ module Edna.Util , ExperimentFileId , ExperimentId , Host + , BuildableResponseLog (..) , IdType (..) , MeasurementId , MethodologyId @@ -57,7 +58,7 @@ import Database.Beam.Backend (SqlSerial(..)) import Fmt (Buildable(..), Builder, pretty, (+|), (|+)) import qualified GHC.Generics as G import Servant (FromHttpApiData(..)) -import Servant.Util.Combinators.Logging (ForResponseLog, buildForResponse) +import Servant.Util.Combinators.Logging (ForResponseLog(..), buildForResponse) import qualified Text.ParserCombinators.ReadP as ReadP import Text.Read (Read(..), read) import qualified Text.Show @@ -235,6 +236,13 @@ uncurry3 f (a, b, c) = f a b c logUnconditionally :: MonadIO m => Text -> m () logUnconditionally msg = hPutStr stderr (msg <> "\n") +-- | Temporary newtype we use to provide @instance Buildable (ForResponseLog Text)@. +-- Probably will disappear when we introduce @Name@ type. +newtype BuildableResponseLog a = BuildableResponseLog a + +instance Buildable a => Buildable (ForResponseLog (BuildableResponseLog a)) where + build (ForResponseLog (BuildableResponseLog a)) = build a + ---------------- -- SqlId ---------------- diff --git a/backend/src/Edna/Web/Types.hs b/backend/src/Edna/Web/Types.hs index 6042694a..8816fd18 100644 --- a/backend/src/Edna/Web/Types.hs +++ b/backend/src/Edna/Web/Types.hs @@ -4,11 +4,15 @@ -- | Legacy module that currently defines only 'WithId' type and should probably -- be changed somehow. +-- UPD: now it has not only 'WithId', but it should be revised anyway, see EDNA-125. {-# LANGUAGE OverloadedLists #-} +-- https://github.com/serokell/universum/issues/208 +{-# OPTIONS_GHC -Wno-redundant-constraints #-} module Edna.Web.Types ( WithId (..) + , NamesSet (..) -- * Re-exported for convenience , URI (..) @@ -16,6 +20,7 @@ module Edna.Web.Types import Universum +import Data.Aeson (ToJSON) import Data.Aeson.TH (deriveToJSON) import Data.Swagger (SwaggerType(..), ToSchema(..), declareSchemaRef, properties, required, type_) import Data.Swagger.Internal.Schema (unnamed) @@ -25,7 +30,7 @@ import Network.URI (URI(..)) import Network.URI.JSON () import Servant.Util.Combinators.Logging (ForResponseLog(..), buildForResponse, buildListForResponse) -import Edna.Util (SqlId(..), ednaAesonWebOptions) +import Edna.Util (BuildableResponseLog(..), SqlId(..), ednaAesonWebOptions) ---------------- -- General types @@ -46,6 +51,20 @@ instance Buildable t => Buildable (ForResponseLog (WithId k t)) where instance Buildable t => Buildable (ForResponseLog [WithId k t]) where build = buildListForResponse (take 5) +-- | Set of names of some entities. +-- +-- For now the primary reason to have this type is to define 'Buildable' for it +-- wrapped into 'ForResponseLog'. +newtype NamesSet = NamesSet + { unNamesSet :: Set Text + } deriving stock (Show) + deriving newtype (Eq, ToJSON, ToSchema, Container) + +instance Buildable (ForResponseLog NamesSet) where + build (ForResponseLog names) = + buildListForResponse (take 10) + (ForResponseLog . map BuildableResponseLog . toList $ names) + ---------------- -- JSON ---------------- diff --git a/backend/test/Test/Gen.hs b/backend/test/Test/Gen.hs index c75057e6..7728f1fd 100644 --- a/backend/test/Test/Gen.hs +++ b/backend/test/Test/Gen.hs @@ -85,6 +85,10 @@ genWithId genT = WithId <$> genSqlId <*> genT genName :: MonadGen m => m Text genName = Gen.text (Range.linear 1 30) Gen.unicode +genNamesSet :: MonadGen m => m NamesSet +genNamesSet = NamesSet . Set.fromList <$> + Gen.list (Range.linear 0 5) (Gen.text (Range.linear 1 30) Gen.unicode) + genDescription :: MonadGen m => m Text genDescription = Gen.text (Range.linear 5 200) Gen.unicode @@ -286,6 +290,9 @@ deriving newtype instance Arbitrary (SqlId t) instance Arbitrary t => Arbitrary (WithId k t) where arbitrary = hedgehog $ genWithId HQC.arbitrary +instance Arbitrary NamesSet where + arbitrary = hedgehog genNamesSet + instance Arbitrary URI where arbitrary = hedgehog genURI