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..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, 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 } diff --git a/backend/src/Edna/Dashboard/Web/Types.hs b/backend/src/Edna/Dashboard/Web/Types.hs index 0dd4e08a..2a403ce2 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 (..) @@ -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 diff --git a/backend/src/Edna/Library/DB/Query.hs b/backend/src/Edna/Library/DB/Query.hs index 1bbc7ffa..cbc79abd 100644 --- a/backend/src/Edna/Library/DB/Query.hs +++ b/backend/src/Edna/Library/DB/Query.hs @@ -9,13 +9,16 @@ module Edna.Library.DB.Query ( getTargetById , getTargets + , getTargetNames , getCompoundById , getCompounds + , getCompoundNames , editCompoundChemSoft , editCompoundMde , getMethodologyById , getMethodologyByName , getMethodologies + , getMethodologyNames , deleteMethodology , insertMethodology , updateMethodology @@ -23,6 +26,7 @@ module Edna.Library.DB.Query , getProjectByName , getProjectWithCompoundsById , getProjectsWithCompounds + , getProjectNames , insertProject , updateProject , touchProject @@ -47,7 +51,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 +132,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 +170,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 @@ -242,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 @@ -339,7 +358,12 @@ projectsWithCompounds projectIdEither = fieldSort @"lastUpdate" pLastUpdate .*. HNil --- | Insert project and return its DB value +-- | 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 insertProject ProjectReq{..} = runInsertReturningOne' $ diff --git a/backend/src/Edna/Library/Service.hs b/backend/src/Edna/Library/Service.hs index 6ee90005..f9ba8717 100644 --- a/backend/src/Edna/Library/Service.hs +++ b/backend/src/Edna/Library/Service.hs @@ -21,6 +21,12 @@ module Edna.Library.Service , getProjects , addProject , updateProject + + -- * 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/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..7728f1fd 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 @@ -83,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 @@ -167,6 +173,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 @@ -276,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 @@ -314,6 +331,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