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