Skip to content

Commit

Permalink
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
Add "names" getters to edna-server
Browse files Browse the repository at this point in the history
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.
gromakovsky committed May 7, 2021

Verified

This commit was signed with the committer’s verified signature. The key has expired.
gromakovsky Ivan Gromakovskii
1 parent 65a1641 commit 7090ab3
Showing 8 changed files with 101 additions and 18 deletions.
15 changes: 12 additions & 3 deletions backend/src/Edna/Dashboard/Web/API.hs
Original file line number Diff line number Diff line change
@@ -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
}
11 changes: 2 additions & 9 deletions backend/src/Edna/Dashboard/Web/Types.hs
Original file line number Diff line number Diff line change
@@ -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" <>
12 changes: 12 additions & 0 deletions backend/src/Edna/Library/DB/Query.hs
Original file line number Diff line number Diff line change
@@ -18,13 +18,15 @@ module Edna.Library.DB.Query
, getMethodologyById
, getMethodologyByName
, getMethodologies
, getMethodologyNames
, deleteMethodology
, insertMethodology
, updateMethodology
, getProjectById
, 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
2 changes: 2 additions & 0 deletions backend/src/Edna/Library/Service.hs
Original file line number Diff line number Diff line change
@@ -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
41 changes: 37 additions & 4 deletions backend/src/Edna/Library/Web/API.hs
Original file line number Diff line number Diff line change
@@ -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
}
10 changes: 9 additions & 1 deletion backend/src/Edna/Util.hs
Original file line number Diff line number Diff line change
@@ -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
----------------
21 changes: 20 additions & 1 deletion backend/src/Edna/Web/Types.hs
Original file line number Diff line number Diff line change
@@ -4,18 +4,23 @@

-- | 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 (..)
) where

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
----------------
7 changes: 7 additions & 0 deletions backend/test/Test/Gen.hs
Original file line number Diff line number Diff line change
@@ -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

0 comments on commit 7090ab3

Please sign in to comment.