]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/API/Search.hs
Merge branch 'dev' into dev-phylo
[gargantext.git] / src / Gargantext / API / Search.hs
1 {-|
2 Module : Gargantext.API.Count
3 Description : Server API
4 Copyright : (c) CNRS, 2017-Present
5 License : AGPL + CECILL v3
6 Maintainer : team@gargantext.org
7 Stability : experimental
8 Portability : POSIX
9
10 Count API part of Gargantext.
11 -}
12
13 {-# LANGUAGE TemplateHaskell #-}
14 {-# LANGUAGE TypeOperators #-}
15 {-# LANGUAGE DeriveAnyClass #-}
16
17 module Gargantext.API.Search
18 where
19
20 import Data.Aeson hiding (defaultTaggedObject)
21 import Data.Maybe (fromMaybe)
22 import Data.Swagger hiding (fieldLabelModifier, Contact)
23 import Data.Text (Text)
24 import Data.Time (UTCTime)
25 import GHC.Generics (Generic)
26 import Gargantext.API.Prelude (GargServer)
27 import Gargantext.Core.Utils.Prefix (unPrefixSwagger, unCapitalize, dropPrefix)
28 import Gargantext.Database.Action.Flow.Pairing (isPairedWith)
29 import Gargantext.Database.Action.Search
30 import Gargantext.Database.Admin.Types.Hyperdata (HyperdataContact(..), HyperdataDocument(..), ContactWho(..))
31 import Gargantext.Database.Admin.Types.Hyperdata.Contact (_cw_organization)
32 import Gargantext.Database.Admin.Types.Node
33 import Gargantext.Database.Query.Facet
34 import Gargantext.Prelude
35 import Gargantext.Utils.Aeson (defaultTaggedObject)
36 import Servant
37 import Test.QuickCheck (elements)
38 import Test.QuickCheck.Arbitrary
39 import qualified Data.Text as Text
40
41 -----------------------------------------------------------------------
42 -- TODO-ACCESS: CanSearch? or is it part of CanGetNode
43 -- TODO-EVENTS: No event, this is a read-only query.
44 type API results = Summary "Search endpoint"
45 :> ReqBody '[JSON] SearchQuery
46 :> QueryParam "offset" Int
47 :> QueryParam "limit" Int
48 :> QueryParam "order" OrderBy
49 :> Post '[JSON] results
50 -----------------------------------------------------------------------
51 -- | Api search function
52 api :: NodeId -> GargServer (API SearchResult)
53
54 api nId (SearchQuery q SearchDoc) o l order =
55 SearchResult <$> SearchResultDoc
56 <$> map (toRow nId)
57 <$> searchInCorpus nId False q o l order
58
59 api nId (SearchQuery q SearchContact) o l order = do
60 printDebug "isPairedWith" nId
61 aIds <- isPairedWith nId NodeAnnuaire
62 -- TODO if paired with several corpus
63 case head aIds of
64 Nothing -> pure $ SearchResult
65 $ SearchNoResult "[G.A.Search] pair corpus with an Annuaire"
66 Just aId -> SearchResult
67 <$> SearchResultContact
68 <$> map (toRow aId)
69 <$> searchInCorpusWithContacts nId aId q o l order
70
71 -----------------------------------------------------------------------
72 -----------------------------------------------------------------------
73 -- | Main Types
74 -----------------------------------------------------------------------
75 data SearchType = SearchDoc | SearchContact
76 deriving (Generic)
77 instance FromJSON SearchType where
78 parseJSON = genericParseJSON (defaultOptions { sumEncoding = ObjectWithSingleField })
79 instance ToJSON SearchType where
80 toJSON = genericToJSON (defaultOptions { sumEncoding = ObjectWithSingleField })
81 instance ToSchema SearchType
82 instance Arbitrary SearchType where
83 arbitrary = elements [SearchDoc, SearchContact]
84
85 -----------------------------------------------------------------------
86 data SearchQuery =
87 SearchQuery { query :: ![Text]
88 , expected :: !SearchType
89 }
90 deriving (Generic)
91 instance FromJSON SearchQuery where
92 parseJSON = genericParseJSON defaultOptions
93 instance ToJSON SearchQuery where
94 toJSON = genericToJSON defaultOptions
95 instance ToSchema SearchQuery
96 {-
97 where
98 declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "")
99 -}
100
101 instance Arbitrary SearchQuery where
102 arbitrary = elements [SearchQuery ["electrodes"] SearchDoc]
103 -- arbitrary = elements [SearchQuery "electrodes" 1 ] --SearchDoc]
104 -----------------------------------------------------------------------
105 data SearchResult =
106 SearchResult { result :: !SearchResultTypes}
107 deriving (Generic)
108
109 instance FromJSON SearchResult where
110 parseJSON = genericParseJSON defaultOptions
111
112 instance ToJSON SearchResult where
113 toJSON = genericToJSON defaultOptions
114
115 instance ToSchema SearchResult
116 {-
117 where
118 declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "")
119 -}
120
121 instance Arbitrary SearchResult where
122 arbitrary = SearchResult <$> arbitrary
123
124
125 data SearchResultTypes =
126 SearchResultDoc { docs :: ![Row] }
127 | SearchResultContact { contacts :: ![Row] }
128 | SearchNoResult { message :: !Text }
129 deriving (Generic)
130 instance FromJSON SearchResultTypes where
131 parseJSON = genericParseJSON (defaultOptions { sumEncoding = defaultTaggedObject })
132 instance ToJSON SearchResultTypes where
133 toJSON = genericToJSON (defaultOptions { sumEncoding = defaultTaggedObject })
134
135 instance Arbitrary SearchResultTypes where
136 arbitrary = do
137 srd <- SearchResultDoc <$> arbitrary
138 src <- SearchResultContact <$> arbitrary
139 srn <- pure $ SearchNoResult "No result because.."
140 elements [srd, src, srn]
141
142 instance ToSchema SearchResultTypes where
143 declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "")
144
145
146 --------------------------------------------------------------------
147
148 data Row =
149 Document { id :: !NodeId
150 , created :: !UTCTime
151 , title :: !Text
152 , hyperdata :: !HyperdataRow
153 , category :: !Int
154 , score :: !Int
155 }
156 | Contact { c_id :: !Int
157 , c_created :: !UTCTime
158 , c_hyperdata :: !HyperdataRow
159 , c_score :: !Int
160 , c_annuaireId :: !NodeId
161 }
162 deriving (Generic)
163 instance FromJSON Row
164 where
165 parseJSON = genericParseJSON
166 ( defaultOptions { sumEncoding = defaultTaggedObject } )
167 instance ToJSON Row
168 where
169 toJSON = genericToJSON (defaultOptions { sumEncoding = defaultTaggedObject })
170 instance Arbitrary Row where
171 arbitrary = arbitrary
172
173 instance ToSchema Row where
174 declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "")
175
176 class ToRow a where
177 toRow :: NodeId -> a -> Row
178
179 instance ToRow FacetDoc where
180 toRow _ (FacetDoc { .. }) =
181 Document { id = facetDoc_id
182 , created = facetDoc_created
183 , title = facetDoc_title
184 , hyperdata = toHyperdataRow facetDoc_hyperdata
185 , category = fromMaybe 0 facetDoc_category
186 , score = round $ fromMaybe 0 facetDoc_score }
187
188 -- | TODO rename FacetPaired
189 type FacetContact = FacetPaired Int UTCTime HyperdataContact Int
190
191 instance ToRow FacetContact where
192 toRow annuaireId (FacetPaired nId utc h s) = Contact nId utc (toHyperdataRow h) s annuaireId
193
194
195 --------------------------------------------------------------------
196 data HyperdataRow =
197 HyperdataRowDocument { _hr_abstract :: !Text
198 , _hr_authors :: !Text
199 , _hr_bdd :: !Text
200 , _hr_doi :: !Text
201 , _hr_institutes :: !Text
202 , _hr_language_iso2 :: !Text
203 , _hr_page :: !Int
204 , _hr_publication_date :: !Text
205 , _hr_publication_day :: !Int
206 , _hr_publication_hour :: !Int
207 , _hr_publication_minute :: !Int
208 , _hr_publication_month :: !Int
209 , _hr_publication_second :: !Int
210 , _hr_publication_year :: !Int
211 , _hr_source :: !Text
212 , _hr_title :: !Text
213 , _hr_url :: !Text
214 , _hr_uniqId :: !Text
215 , _hr_uniqIdBdd :: !Text
216 }
217 | HyperdataRowContact { _hr_firstname :: !Text
218 , _hr_lastname :: !Text
219 , _hr_labs :: !Text
220 }
221 deriving (Generic)
222 instance FromJSON HyperdataRow
223 where
224 parseJSON = genericParseJSON
225 ( defaultOptions
226 { sumEncoding = defaultTaggedObject
227 , fieldLabelModifier = unCapitalize . dropPrefix "_hr_"
228 , omitNothingFields = False
229 }
230 )
231 instance ToJSON HyperdataRow
232 where
233 toJSON = genericToJSON
234 ( defaultOptions
235 { sumEncoding = defaultTaggedObject
236 , fieldLabelModifier = unCapitalize . dropPrefix "_hr_"
237 , omitNothingFields = False
238 }
239 )
240
241 instance Arbitrary HyperdataRow where
242 arbitrary = arbitrary
243
244 instance ToSchema HyperdataRow where
245 declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_hr_")
246
247 class ToHyperdataRow a where
248 toHyperdataRow :: a -> HyperdataRow
249
250 instance ToHyperdataRow HyperdataDocument where
251 toHyperdataRow (HyperdataDocument { .. }) =
252 HyperdataRowDocument
253 { _hr_abstract = fromMaybe "" _hd_abstract
254 , _hr_authors = fromMaybe "" _hd_authors
255 , _hr_bdd = fromMaybe "" _hd_bdd
256 , _hr_doi = fromMaybe "" _hd_doi
257 , _hr_institutes = fromMaybe "" _hd_institutes
258 , _hr_language_iso2 = fromMaybe "EN" _hd_language_iso2
259 , _hr_page = fromMaybe 0 _hd_page
260 , _hr_publication_date = fromMaybe "" _hd_publication_date
261 , _hr_publication_day = fromMaybe 1 _hd_publication_day
262 , _hr_publication_hour = fromMaybe 1 _hd_publication_hour
263 , _hr_publication_minute = fromMaybe 1 _hd_publication_minute
264 , _hr_publication_month = fromMaybe 1 _hd_publication_month
265 , _hr_publication_second = fromMaybe 1 _hd_publication_second
266 , _hr_publication_year = fromMaybe 2020 _hd_publication_year
267 , _hr_source = fromMaybe "" _hd_source
268 , _hr_title = fromMaybe "Title" _hd_title
269 , _hr_url = fromMaybe "" _hd_url
270 , _hr_uniqId = fromMaybe "" _hd_uniqId
271 , _hr_uniqIdBdd = fromMaybe "" _hd_uniqIdBdd }
272
273 instance ToHyperdataRow HyperdataContact where
274 toHyperdataRow (HyperdataContact { _hc_who = Just (ContactWho _ fn ln _ _), _hc_where = ou} ) =
275 HyperdataRowContact (fromMaybe "FirstName" fn) (fromMaybe "LastName" ln) ou'
276 where
277 ou' = maybe "CNRS" (Text.intercalate " " . _cw_organization) (head ou)
278 toHyperdataRow (HyperdataContact {}) =
279 HyperdataRowContact "FirstName" "LastName" "Labs"