From 9b94b47f69c1a1d5c8825df9a8ba2a41f9c670a2 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Alexandre=20Delano=C3=AB?= <devel+git@delanoe.org>
Date: Tue, 28 Jul 2020 16:08:30 +0200
Subject: [PATCH] [API] Generic instances fixed for Document (WIP)
---
src/Gargantext/API/Node.hs | 2 +-
src/Gargantext/API/Search.hs | 188 +++++++++++++++---
src/Gargantext/Core/Flow/Types.hs | 2 +-
.../Admin/Types/Hyperdata/Document.hs | 30 ++-
src/Gargantext/Database/Schema/Node.hs | 25 +--
5 files changed, 199 insertions(+), 48 deletions(-)
diff --git a/src/Gargantext/API/Node.hs b/src/Gargantext/API/Node.hs
index a8e4be34..6432af1a 100644
--- a/src/Gargantext/API/Node.hs
+++ b/src/Gargantext/API/Node.hs
@@ -129,7 +129,7 @@ type NodeAPI a = Get '[JSON] (Node a)
:<|> "ngrams" :> TableNgramsApi
:<|> "category" :> CatApi
- :<|> "search" :> (Search.API Int) -- Search.SearchResult)
+ :<|> "search" :> (Search.API Search.SearchResult)
:<|> "share" :> Share.API
-- Pairing utilities
diff --git a/src/Gargantext/API/Search.hs b/src/Gargantext/API/Search.hs
index d596b259..7ea546d0 100644
--- a/src/Gargantext/API/Search.hs
+++ b/src/Gargantext/API/Search.hs
@@ -20,16 +20,17 @@ module Gargantext.API.Search
where
import Data.Aeson
-import Data.Swagger
+import Data.Maybe (fromMaybe)
+import Data.Swagger hiding (fieldLabelModifier)
import Data.Text (Text)
--- import Data.Time (UTCTime)
+import Data.Time (UTCTime)
import GHC.Generics (Generic)
import Gargantext.API.Prelude (GargServer)
-import Gargantext.Core.Utils.Prefix (unPrefixSwagger)
+import Gargantext.Core.Utils.Prefix (unPrefixSwagger, unCapitalize, dropPrefix)
import Gargantext.Database.Query.Facet
--- import Gargantext.Database.Action.Search
--- import Gargantext.Database.Action.Flow.Pairing (isPairedWith)
--- import Gargantext.Database.Admin.Types.Hyperdata (HyperdataContact)
+import Gargantext.Database.Action.Search
+import Gargantext.Database.Action.Flow.Pairing (isPairedWith)
+import Gargantext.Database.Admin.Types.Hyperdata (HyperdataContact, HyperdataDocument(..))
import Gargantext.Database.Admin.Types.Node
import Gargantext.Prelude
import Servant
@@ -47,23 +48,17 @@ type API results = Summary "Search endpoint"
:> QueryParam "order" OrderBy
:> Post '[JSON] results
-----------------------------------------------------------------------
-api :: NodeId -> GargServer (API Int) -- SearchResult)
-api _ _ _ _ _ = undefined
-
-{-
-
api :: NodeId -> GargServer (API SearchResult)
api nId (SearchQuery q SearchDoc) o l order =
- SearchResultDoc <$> searchInCorpus nId False q o l order
+ SearchResult <$> SearchResultDoc <$> map toRow <$> searchInCorpus nId False q o l order
api nId (SearchQuery q SearchContact) o l order = do
- undefined
- {- aIds <- isPairedWith NodeAnnuaire nId
+ aIds <- isPairedWith NodeAnnuaire nId
-- TODO if paired with several corpus
case head aIds of
- Nothing -> pure $ SearchNoResult "[G.A.Search] pair corpus with an Annuaire"
- Just aId -> SearchResultContact <$> searchInCorpusWithContacts nId aId q o l order
- -}
--}
+ Nothing -> pure $ SearchResult $ SearchNoResult "[G.A.Search] pair corpus with an Annuaire"
+ Just aId -> SearchResult <$> SearchResultContact <$> searchInCorpusWithContacts nId aId q o l order
+api _ _ _ _ _ = undefined
+
-----------------------------------------------------------------------
-----------------------------------------------------------------------
-- | Main Types
@@ -110,32 +105,161 @@ instance Arbitrary SearchQuery where
-- arbitrary = elements [SearchQuery "electrodes" 1 ] --SearchDoc]
-----------------------------------------------------------------------
-data SearchResult = SearchResultDoc { docs :: ![FacetDoc]}
--- | SearchResultContact { contacts :: ![FacetPaired Int UTCTime HyperdataContact Int] }
--- | SearchNoResult { message :: !Text }
-
- deriving (Generic)
+data SearchResult =
+ SearchResult { result :: !SearchResultTypes
+ }
+ | SearchResultErr !Text
+ deriving (Generic)
instance FromJSON SearchResult
-{-
where
parseJSON = genericParseJSON (defaultOptions { sumEncoding = ObjectWithSingleField })
--}
instance ToJSON SearchResult
-{-
where
toJSON = genericToJSON (defaultOptions { sumEncoding = ObjectWithSingleField })
+
+instance ToSchema SearchResult
+{-
+ where
+ declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "")
-}
-
+
instance Arbitrary SearchResult where
+ arbitrary = SearchResult <$> arbitrary
+
+
+data SearchResultTypes = SearchResultDoc { docs :: ![Row]}
+ | SearchResultContact { contacts :: ![FacetPaired Int UTCTime HyperdataContact Int] }
+ | SearchNoResult { message :: !Text }
+
+ deriving (Generic)
+
+instance FromJSON SearchResultTypes
+ where
+ parseJSON = genericParseJSON (defaultOptions { sumEncoding = ObjectWithSingleField })
+
+instance ToJSON SearchResultTypes
+ where
+ toJSON = genericToJSON (defaultOptions { sumEncoding = ObjectWithSingleField })
+
+instance Arbitrary SearchResultTypes where
arbitrary = do
srd <- SearchResultDoc <$> arbitrary
- -- src <- SearchResultContact <$> arbitrary
- -- srn <- pure $ SearchNoResult "No result because.."
- elements [srd] -- , src, srn]
+ src <- SearchResultContact <$> arbitrary
+ srn <- pure $ SearchNoResult "No result because.."
+ elements [srd, src, srn]
+
+instance ToSchema SearchResultTypes where
+ declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "")
+
+
+--------------------------------------------------------------------
+
+data Row =
+ Document { id :: !NodeId
+ , created :: !UTCTime
+ , title :: !Text
+ , hyperdata :: !HyperdataRow
+ , category :: !Int
+ , score :: !Int
+ }
+ | Contact { c_id :: !Int
+ , c_created :: !Text
+ , c_hyperdata :: !HyperdataContact
+ , c_score :: !Int
+ }
+ deriving (Generic)
+
+instance FromJSON Row
+ where
+ parseJSON = genericParseJSON (defaultOptions { sumEncoding = ObjectWithSingleField })
+
+instance ToJSON Row
+ where
+ toJSON = genericToJSON (defaultOptions { sumEncoding = ObjectWithSingleField })
+
+instance Arbitrary Row where
+ arbitrary = arbitrary
+
+instance ToSchema Row where
+ declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "")
+
+toRow :: FacetDoc -> Row
+toRow (FacetDoc nId utc t h mc md) = Document nId utc t (toHyperdataRow h) (fromMaybe 0 mc) (round $ fromMaybe 0 md)
+
+--------------------------------------------------------------------
+
+data HyperdataRow =
+ HyperdataRowDocument { _hr_bdd :: !Text
+ , _hr_doi :: !Text
+ , _hr_url :: !Text
+ , _hr_uniqId :: !Text
+ , _hr_uniqIdBdd :: !Text
+ , _hr_page :: !Int
+ , _hr_title :: !Text
+ , _hr_authors :: !Text
+ , _hr_institutes :: !Text
+ , _hr_source :: !Text
+ , _hr_abstract :: !Text
+ , _hr_publication_date :: !Text
+ , _hr_publication_year :: !Int
+ , _hr_publication_month :: !Int
+ , _hr_publication_day :: !Int
+ , _hr_publication_hour :: !Int
+ , _hr_publication_minute :: !Int
+ , _hr_publication_second :: !Int
+ , _hr_language_iso2 :: !Text
+ }
+ | HyperdataRowContact { _hr_name :: !Text }
+ deriving (Generic)
+
+instance FromJSON HyperdataRow
+ where
+ parseJSON = genericParseJSON
+ ( defaultOptions
+ { sumEncoding = ObjectWithSingleField
+ , fieldLabelModifier = unCapitalize . dropPrefix "_hr_"
+ , omitNothingFields = True
+ }
+ )
+
+instance ToJSON HyperdataRow
+ where
+ toJSON = genericToJSON
+ ( defaultOptions
+ { sumEncoding = ObjectWithSingleField
+ , fieldLabelModifier = unCapitalize . dropPrefix "_hr_"
+ , omitNothingFields = True
+ }
+ )
+
+instance Arbitrary HyperdataRow where
+ arbitrary = arbitrary
-instance ToSchema SearchResult where
- declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "sr_")
+instance ToSchema HyperdataRow where
+ declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_hr_")
+toHyperdataRow :: HyperdataDocument -> HyperdataRow
+toHyperdataRow (HyperdataDocument b d u ui ub p t a i s abs pd py pm pda ph pmin psec l) =
+ HyperdataRowDocument
+ (fromMaybe "" b)
+ (fromMaybe "" d)
+ (fromMaybe "" u)
+ (fromMaybe "" ui)
+ (fromMaybe "" ub)
+ (fromMaybe 0 p)
+ (fromMaybe "Title" t)
+ (fromMaybe "" a)
+ (fromMaybe "" i)
+ (fromMaybe "" s)
+ (fromMaybe "" abs)
+ (fromMaybe "" pd)
+ (fromMaybe 2020 py)
+ (fromMaybe 1 pm)
+ (fromMaybe 1 pda)
+ (fromMaybe 1 ph)
+ (fromMaybe 1 pmin)
+ (fromMaybe 1 psec)
+ (fromMaybe "EN" l)
diff --git a/src/Gargantext/Core/Flow/Types.hs b/src/Gargantext/Core/Flow/Types.hs
index 5c7b8aaa..85c9bd33 100644
--- a/src/Gargantext/Core/Flow/Types.hs
+++ b/src/Gargantext/Core/Flow/Types.hs
@@ -17,7 +17,7 @@ module Gargantext.Core.Flow.Types where
import Control.Lens (Lens')
import Data.Map (Map)
import Data.Maybe (Maybe)
-
+-- import Control.Applicative
import Gargantext.Text (HasText(..))
import Gargantext.Core.Types.Main (HashId)
import Gargantext.Database.Admin.Types.Hyperdata
diff --git a/src/Gargantext/Database/Admin/Types/Hyperdata/Document.hs b/src/Gargantext/Database/Admin/Types/Hyperdata/Document.hs
index 52aad8c1..84a3f265 100644
--- a/src/Gargantext/Database/Admin/Types/Hyperdata/Document.hs
+++ b/src/Gargantext/Database/Admin/Types/Hyperdata/Document.hs
@@ -21,6 +21,7 @@ Portability : POSIX
module Gargantext.Database.Admin.Types.Hyperdata.Document where
import Gargantext.Prelude
+import Gargantext.Core.Utils.Prefix (unCapitalize, dropPrefix)
import Gargantext.Database.Admin.Types.Hyperdata.Prelude
@@ -44,7 +45,8 @@ data HyperdataDocument = HyperdataDocument { _hd_bdd :: !(Maybe T
, _hd_publication_minute :: !(Maybe Int)
, _hd_publication_second :: !(Maybe Int)
, _hd_language_iso2 :: !(Maybe Text)
- } deriving (Show, Generic)
+ }
+ deriving (Show, Generic)
defaultHyperdataDocument :: HyperdataDocument
@@ -67,6 +69,7 @@ data StatusV3 = StatusV3 { statusV3_error :: !(Maybe Text)
} deriving (Show, Generic)
$(deriveJSON (unPrefix "statusV3_") ''StatusV3)
+
------------------------------------------------------------------------
data HyperdataDocumentV3 = HyperdataDocumentV3 { _hdv3_publication_day :: !(Maybe Int)
, _hdv3_language_iso2 :: !(Maybe Text)
@@ -132,9 +135,32 @@ instance Hyperdata HyperdataDocument
instance Hyperdata HyperdataDocumentV3
------------------------------------------------------------------------
$(makeLenses ''HyperdataDocument)
+makePrisms ''HyperdataDocument
+
$(makeLenses ''HyperdataDocumentV3)
-$(deriveJSON (unPrefix "_hd_") ''HyperdataDocument)
+-- $(deriveJSON (unPrefix "_hd_") ''HyperdataDocument)
+
+instance FromJSON HyperdataDocument
+ where
+ parseJSON = genericParseJSON
+ ( defaultOptions { sumEncoding = ObjectWithSingleField
+ , fieldLabelModifier = unCapitalize . dropPrefix "_hd"
+ , omitNothingFields = True
+ }
+ )
+
+instance ToJSON HyperdataDocument
+ where
+ toJSON = genericToJSON
+ ( defaultOptions { sumEncoding = ObjectWithSingleField
+ , fieldLabelModifier = unCapitalize . dropPrefix "_hd"
+ , omitNothingFields = True
+ }
+ )
+
+
+
$(deriveJSON (unPrefix "_hdv3_") ''HyperdataDocumentV3)
instance ToSchema HyperdataDocument where
diff --git a/src/Gargantext/Database/Schema/Node.hs b/src/Gargantext/Database/Schema/Node.hs
index 60269b1a..a0af4dc1 100644
--- a/src/Gargantext/Database/Schema/Node.hs
+++ b/src/Gargantext/Database/Schema/Node.hs
@@ -156,16 +156,17 @@ $(deriveJSON (unPrefix "_ns_") ''NodePolySearch)
$(makeLenses ''NodePolySearch)
nodeTableSearch :: Table NodeSearchWrite NodeSearchRead
-nodeTableSearch = Table "nodes" (pNodeSearch NodeSearch { _ns_id = optional "id"
- , _ns_typename = required "typename"
- , _ns_userId = required "user_id"
-
- , _ns_parentId = required "parent_id"
- , _ns_name = required "name"
- , _ns_date = optional "date"
-
- , _ns_hyperdata = required "hyperdata"
- , _ns_search = optional "search"
- }
- )
+nodeTableSearch = Table "nodes" ( pNodeSearch
+ NodeSearch { _ns_id = optional "id"
+ , _ns_typename = required "typename"
+ , _ns_userId = required "user_id"
+
+ , _ns_parentId = required "parent_id"
+ , _ns_name = required "name"
+ , _ns_date = optional "date"
+
+ , _ns_hyperdata = required "hyperdata"
+ , _ns_search = optional "search"
+ }
+ )
------------------------------------------------------------------------
--
2.21.0