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