[EDNA-130] Add an optimized getter of filtered experiments

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'

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 ::

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.

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, getMeasurements, getSubExperiment, makePrimarySubExperiment, newSubExperiment,
-  setIsSuspiciousSubExperiment, setNameSubExperiment)
+  (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
@@ -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"
@@ -127,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
@@ -140,9 +158,11 @@ 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
   , deGetSubExperiment = getSubExperiment
   , deGetMeasurements = getMeasurements
+  , deGetActiveProjectNames = NamesSet <$> getActiveProjectNames
   }

backend/src/Edna/Dashboard/Web/Types.hs

@@ -9,6 +9,7 @@ module Edna.Dashboard.Web.Types
   , ExperimentsResp (..)
   , ExperimentResp (..)
   , ExperimentSortingSpec
+  , ExperimentsSummaryResp (..)
   , SubExperimentResp (..)
   , MeasurementResp (..)
   , ExperimentMetadata (..)
@@ -29,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.
@@ -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,37 @@ 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
+
+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 +230,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 +241,9 @@ instance ToSchema NewSubExperimentReq where
 instance ToSchema ExperimentsResp where
   declareNamedSchema = gDeclareNamedSchema
 
+instance ToSchema ExperimentsSummaryResp where
+  declareNamedSchema = gDeclareNamedSchema
+
 instance ToSchema ExperimentResp where
   declareNamedSchema = gDeclareNamedSchema