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