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