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

@@ -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
   }

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

backend/src/Edna/Library/DB/Query.hs

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

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

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
   }

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

backend/src/Edna/Web/Types.hs

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

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