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
  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 Gargantext.Prelude
  35 import Servant
  36 import Test.QuickCheck (elements)
  37 import Test.QuickCheck.Arbitrary
  38 import qualified Data.Text as Text
  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 search function
  51 api :: NodeId -> GargServer (API SearchResult)
  52
  53 api nId (SearchQuery q SearchDoc) o l order =
  54   SearchResult <$> SearchResultDoc
  55                <$> map (toRow nId)
  56                <$> searchInCorpus nId False q o l order
  57
  58 api nId (SearchQuery q SearchContact) o l order = do
  59   printDebug "isPairedWith" nId
  60   aIds <- isPairedWith nId NodeAnnuaire
  61   -- TODO if paired with several corpus
  62   case head aIds of
  63     Nothing  -> pure $ SearchResult
  64               $ SearchNoResult "[G.A.Search] pair corpus with an Annuaire"
  65     Just aId -> SearchResult
  66             <$> SearchResultContact
  67             <$> map (toRow aId)
  68             <$> searchInCorpusWithContacts nId aId q o l order
  69 api _ _ _ _ _ = panic "[G.A.Search.api] undefined"
  70
  71 -----------------------------------------------------------------------
  72 -----------------------------------------------------------------------
  73 -- | Main Types
  74 -----------------------------------------------------------------------
  75 data SearchType = SearchDoc | SearchContact
  76   deriving (Generic)
  77
  78 instance FromJSON  SearchType
  79   where
  80     parseJSON = genericParseJSON (defaultOptions { sumEncoding = ObjectWithSingleField })
  81
  82 instance ToJSON  SearchType
  83   where
  84     toJSON = genericToJSON (defaultOptions { sumEncoding = ObjectWithSingleField })
  85
  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   | SearchQueryErr !Text
  96     deriving (Generic)
  97
  98 instance FromJSON  SearchQuery
  99   where
 100     parseJSON = genericParseJSON (defaultOptions { sumEncoding = ObjectWithSingleField })
 101
 102 instance ToJSON  SearchQuery
 103   where
 104     toJSON = genericToJSON (defaultOptions { sumEncoding = ObjectWithSingleField })
 105
 106 instance ToSchema SearchQuery
 107 {-
 108   where
 109     declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "")
 110 -}
 111
 112 instance Arbitrary SearchQuery where
 113   arbitrary = elements [SearchQuery ["electrodes"] SearchDoc]
 114   -- arbitrary = elements [SearchQuery "electrodes" 1 ] --SearchDoc]
 115 -----------------------------------------------------------------------
 116 data SearchResult =
 117   SearchResult { result :: !SearchResultTypes}
 118   | SearchResultErr !Text
 119     deriving (Generic)
 120
 121 instance FromJSON  SearchResult
 122   where
 123     parseJSON = genericParseJSON (defaultOptions { sumEncoding = ObjectWithSingleField })
 124
 125 instance ToJSON  SearchResult
 126   where
 127     toJSON = genericToJSON (defaultOptions { sumEncoding = ObjectWithSingleField })
 128
 129 instance ToSchema SearchResult
 130 {-
 131   where
 132     declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "")
 133 -}
 134
 135 instance Arbitrary SearchResult where
 136   arbitrary = SearchResult <$> arbitrary
 137
 138
 139 data SearchResultTypes = SearchResultDoc { docs     :: ![Row]}
 140                   | SearchResultContact  { contacts :: ![Row] }
 141                   | SearchNoResult      { message  :: !Text }
 142
 143   deriving (Generic)
 144
 145 instance FromJSON  SearchResultTypes
 146   where
 147     parseJSON = genericParseJSON (defaultOptions { sumEncoding = ObjectWithSingleField })
 148
 149 instance ToJSON  SearchResultTypes
 150   where
 151     toJSON = genericToJSON (defaultOptions { sumEncoding = ObjectWithSingleField })
 152
 153 instance Arbitrary SearchResultTypes where
 154   arbitrary = do
 155     srd <- SearchResultDoc     <$> arbitrary
 156     src <- SearchResultContact <$> arbitrary
 157     srn <- pure $ SearchNoResult "No result because.."
 158     elements [srd, src, srn]
 159
 160 instance ToSchema SearchResultTypes where
 161   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "")
 162
 163
 164 --------------------------------------------------------------------
 165
 166 data Row =
 167   Document { id         :: !NodeId
 168            , created    :: !UTCTime
 169            , title      :: !Text
 170            , hyperdata  :: !HyperdataRow
 171            , category   :: !Int
 172            , score      :: !Int
 173            }
 174   | Contact  { c_id         :: !Int
 175              , c_created    :: !UTCTime
 176              , c_hyperdata  :: !HyperdataRow
 177              , c_score      :: !Int
 178              , c_annuaireId :: !NodeId
 179              }
 180   deriving (Generic)
 181
 182 instance FromJSON  Row
 183   where
 184     parseJSON = genericParseJSON
 185                  ( defaultOptions { sumEncoding = ObjectWithSingleField
 186                                   }
 187                  )
 188
 189 instance ToJSON  Row
 190   where
 191     toJSON = genericToJSON (defaultOptions { sumEncoding = ObjectWithSingleField })
 192
 193 instance Arbitrary Row where
 194   arbitrary = arbitrary
 195
 196 instance ToSchema Row where
 197   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "")
 198
 199 class ToRow a where
 200   toRow :: NodeId -> a -> Row
 201
 202 instance ToRow FacetDoc where
 203   toRow _ (FacetDoc nId utc t h mc _md sc) =
 204     Document nId utc t (toHyperdataRow h) (fromMaybe 0 mc) (round $ fromMaybe 0 sc)
 205
 206 -- | TODO rename FacetPaired
 207 type FacetContact = FacetPaired Int UTCTime HyperdataContact Int
 208
 209 instance ToRow FacetContact where
 210   toRow annuaireId (FacetPaired nId utc h s) = Contact nId utc (toHyperdataRow h) s annuaireId
 211
 212
 213 --------------------------------------------------------------------
 214 data HyperdataRow =
 215   HyperdataRowDocument { _hr_bdd                :: !Text
 216                        , _hr_doi                :: !Text
 217                        , _hr_url                :: !Text
 218                        , _hr_uniqId             :: !Text
 219                        , _hr_uniqIdBdd          :: !Text
 220                        , _hr_page               :: !Int
 221                        , _hr_title              :: !Text
 222                        , _hr_authors            :: !Text
 223                        , _hr_institutes         :: !Text
 224                        , _hr_source             :: !Text
 225                        , _hr_abstract           :: !Text
 226                        , _hr_publication_date   :: !Text
 227                        , _hr_publication_year   :: !Int
 228                        , _hr_publication_month  :: !Int
 229                        , _hr_publication_day    :: !Int
 230                        , _hr_publication_hour   :: !Int
 231                        , _hr_publication_minute :: !Int
 232                        , _hr_publication_second :: !Int
 233                        , _hr_language_iso2      :: !Text
 234                        }
 235   | HyperdataRowContact { _hr_firstname :: !Text
 236                         , _hr_lastname  :: !Text
 237                         , _hr_labs      :: !Text
 238                         }
 239   deriving (Generic)
 240
 241 instance FromJSON  HyperdataRow
 242   where
 243     parseJSON = genericParseJSON
 244               ( defaultOptions
 245                 { sumEncoding = ObjectWithSingleField
 246                 , fieldLabelModifier = unCapitalize . dropPrefix "_hr_"
 247                 , omitNothingFields = False
 248                 }
 249               )
 250
 251 instance ToJSON  HyperdataRow
 252   where
 253     toJSON = genericToJSON
 254                ( defaultOptions
 255                 { sumEncoding = ObjectWithSingleField
 256                 , fieldLabelModifier = unCapitalize . dropPrefix "_hr_"
 257                 , omitNothingFields = False
 258                 }
 259               )
 260
 261 instance Arbitrary HyperdataRow where
 262   arbitrary = arbitrary
 263
 264 instance ToSchema HyperdataRow where
 265   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_hr_")
 266
 267 class ToHyperdataRow a where
 268   toHyperdataRow :: a -> HyperdataRow
 269
 270 instance ToHyperdataRow HyperdataDocument where
 271   toHyperdataRow (HyperdataDocument b d u ui ub p t a i s abs' pd py pm pda ph pmin psec l) =
 272     HyperdataRowDocument
 273       (fromMaybe "" b)
 274       (fromMaybe "" d)
 275       (fromMaybe "" u)
 276       (fromMaybe "" ui)
 277       (fromMaybe "" ub)
 278       (fromMaybe 0 p)
 279       (fromMaybe "Title" t)
 280       (fromMaybe "" a)
 281       (fromMaybe "" i)
 282       (fromMaybe "" s)
 283       (fromMaybe "" abs')
 284       (fromMaybe "" pd)
 285       (fromMaybe 2020 py)
 286       (fromMaybe 1 pm)
 287       (fromMaybe 1 pda)
 288       (fromMaybe 1 ph)
 289       (fromMaybe 1 pmin)
 290       (fromMaybe 1 psec)
 291       (fromMaybe "EN" l)
 292
 293 instance ToHyperdataRow HyperdataContact where
 294   toHyperdataRow (HyperdataContact _ (Just (ContactWho _ fn ln _ _)) ou _ _ _ _ _ ) =
 295     HyperdataRowContact (fromMaybe "FirstName" fn) (fromMaybe "LastName" ln) ou'
 296       where
 297         ou' = maybe "CNRS" (Text.intercalate " " . _cw_organization) (head ou)
 298   toHyperdataRow (HyperdataContact _ _ _ _ _ _ _ _ ) =
 299     HyperdataRowContact "FirstName" "LastName" "Labs"