src/Gargantext/API/Node/Corpus/Searx.hs

   1 {-# LANGUAGE TemplateHaskell #-}
   2
   3 module Gargantext.API.Node.Corpus.Searx where
   4
   5
   6
   7 import Control.Lens (view)
   8 import qualified Data.Aeson as Aeson
   9 import Data.Aeson.TH (deriveJSON)
  10 import Data.Either (Either(..))
  11 import qualified Data.HashMap.Strict as HashMap
  12 import qualified Data.Text as T
  13 import Data.Time.Calendar (Day, toGregorian)
  14 import Data.Time.Format (defaultTimeLocale, formatTime, parseTimeM)
  15 import Data.Tuple.Select (sel1, sel2, sel3)
  16 import GHC.Generics (Generic)
  17 import Network.HTTP.Client
  18 import Network.HTTP.Client.TLS
  19
  20 import qualified Prelude
  21 import Protolude (catMaybes, encodeUtf8, rightToMaybe, Text)
  22 import Gargantext.Prelude
  23 import Gargantext.Prelude.Config
  24
  25 import Gargantext.API.Admin.Orchestrator.Types (JobLog(..))
  26 --import Gargantext.API.Admin.Types (HasSettings)
  27 import Gargantext.API.Job (jobLogSuccess)
  28 import Gargantext.Core (Lang(..), PosTagAlgo(..))
  29 import qualified Gargantext.Core.Text.Corpus.API as API
  30 import Gargantext.Core.Text.List (buildNgramsLists)
  31 import Gargantext.Core.Text.List.Group.WithStem ({-StopSize(..),-} GroupParams(..))
  32 import Gargantext.Core.Text.Terms (TermType(..))
  33 import Gargantext.Core.Types.Individu (User(..))
  34 import Gargantext.Core.Utils.Prefix (unPrefix)
  35 import Gargantext.Database.Action.Flow (insertMasterDocs) --, DataText(..))
  36 import Gargantext.Database.Action.Flow.List (flowList_DbRepo)
  37 import Gargantext.Database.Action.Flow.Types (FlowCmdM)
  38 import Gargantext.Database.Action.User (getUserId)
  39 import Gargantext.Database.Admin.Config (userMaster)
  40 import Gargantext.Database.Admin.Types.Hyperdata.Corpus (HyperdataCorpus)
  41 import Gargantext.Database.Admin.Types.Hyperdata.Document (HyperdataDocument(..))
  42 import Gargantext.Database.Admin.Types.Node (CorpusId, ListId)
  43 import Gargantext.Database.Prelude (hasConfig)
  44 import Gargantext.Database.Query.Table.Node (defaultListMaybe, getOrMkList)
  45 import Gargantext.Database.Query.Tree.Root (getOrMk_RootWithCorpus)
  46 import qualified Gargantext.Database.Query.Table.Node.Document.Add  as Doc  (add)
  47
  48 langToSearx :: Lang -> Text
  49 langToSearx EN = "en-US"
  50 langToSearx FR = "fr-FR"
  51 langToSearx All = "en-US"
  52
  53 data SearxResult = SearxResult
  54   { _sr_url           :: Text
  55   , _sr_title         :: Text
  56   , _sr_content       :: Maybe Text
  57   , _sr_engine        :: Text
  58   , _sr_score         :: Double
  59   , _sr_category      :: Text
  60   , _sr_pretty_url    :: Text
  61   , _sr_publishedDate :: Text   -- "Nov 19, 2021"
  62   , _sr_pubdate       :: Text  -- "2021-11-19 02:12:00+0000"
  63   }
  64   deriving (Show, Eq, Generic)
  65 --  , _sr_parsed_url
  66 --  , _sr_engines
  67 --  , _sr_positions
  68
  69 $(deriveJSON (unPrefix "_sr_") ''SearxResult)
  70
  71 data SearxResponse = SearxResponse
  72   { _srs_query                :: Text
  73   , _srs_number_of_results    :: Int
  74   , _srs_results              :: [SearxResult] }
  75   deriving (Show, Eq, Generic)
  76 -- , _srs_answers
  77 -- , _srs_corrections
  78 -- , _srs_infoboxes
  79 --  , _srs_suggestions          :: [Text]
  80 --  , _srs_unresponsive_engines :: [Text] }
  81
  82 $(deriveJSON (unPrefix "_srs_") ''SearxResponse)
  83
  84 data FetchSearxParams = FetchSearxParams
  85   { _fsp_language :: Lang
  86   , _fsp_manager :: Manager
  87   , _fsp_pageno  :: Int
  88   , _fsp_query   :: Text
  89   , _fsp_url     :: Text
  90   }
  91
  92 fetchSearxPage :: FetchSearxParams -> IO (Either Prelude.String SearxResponse)
  93 fetchSearxPage (FetchSearxParams { _fsp_language
  94                                  , _fsp_manager
  95                                  , _fsp_pageno
  96                                  , _fsp_query
  97                                  , _fsp_url }) = do
  98   -- searx search API:
  99   -- https://searx.github.io/searx/dev/search_api.html?highlight=json
 100   req <- parseRequest $ T.unpack _fsp_url
 101   let request = urlEncodedBody
 102         [ --("category_general", "1")
 103           ("q", encodeUtf8 _fsp_query)
 104         , ("categories", "news")  -- https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/70#note_3976
 105         , ("pageno", encodeUtf8 $ T.pack $ show _fsp_pageno)
 106           --, ("time_range", "None")
 107         , ("language", encodeUtf8 $ langToSearx _fsp_language)
 108         , ("format", "json")
 109         ] req
 110   res <- httpLbs request _fsp_manager
 111   let dec = Aeson.eitherDecode $ responseBody res :: (Either Prelude.String SearxResponse)
 112   pure dec
 113
 114 insertSearxResponse :: (MonadBase IO m, FlowCmdM env err m)
 115                     => User
 116                     -> CorpusId
 117                     -> ListId
 118                     -> Lang
 119                     -> Either Prelude.String SearxResponse
 120                     -> m ()
 121 insertSearxResponse _ _ _ _ (Left _) = pure ()
 122 insertSearxResponse user cId listId l (Right (SearxResponse { _srs_results })) = do
 123   let docs = hyperdataDocumentFromSearxResult l <$> _srs_results
 124   --printDebug "[triggerSearxSearch] docs" docs
 125   -- docs :: [Either Text HyperdataDocument]
 126   let docs' = catMaybes $ rightToMaybe <$> docs
 127   Prelude.mapM_ (\(HyperdataDocument { _hd_title, _hd_publication_year, _hd_publication_date }) -> do
 128     printDebug "[triggerSearxSearch] doc time" $
 129       "[title] " <> (show _hd_title) <>
 130       " :: [publication_year] " <> (show _hd_publication_year) <>
 131       " :: [publication_date] " <> (show _hd_publication_date)
 132     ) docs'
 133   --_ <- flowDataText user (DataNew [docs']) (Multi l) cId Nothing logStatus
 134   let mCorpus = Nothing :: Maybe HyperdataCorpus
 135   ids <- insertMasterDocs mCorpus (Multi l) docs'
 136   _ <- Doc.add cId ids
 137   (_masterUserId, _masterRootId, masterCorpusId)
 138     <- getOrMk_RootWithCorpus (UserName userMaster) (Left "") mCorpus
 139   let
 140     gp = case l of
 141       FR -> GroupWithPosTag l Spacy HashMap.empty
 142       _       -> GroupWithPosTag l CoreNLP HashMap.empty
 143   ngs         <- buildNgramsLists user cId masterCorpusId Nothing gp
 144   _userListId <- flowList_DbRepo listId ngs
 145
 146   pure ()
 147
 148 -- TODO Make an async task out of this?
 149 triggerSearxSearch :: (MonadBase IO m, FlowCmdM env err m)
 150             => User
 151             -> CorpusId
 152             -> API.Query
 153             -> Lang
 154             -> (JobLog -> m ())
 155             -> m JobLog
 156 triggerSearxSearch user cId q l logStatus = do
 157   let numPages = 100
 158   let jobLog = JobLog { _scst_succeeded = Just 0
 159                       , _scst_failed    = Just 0
 160                       , _scst_remaining = Just numPages
 161                       , _scst_events    = Just []
 162                       }
 163   logStatus jobLog
 164
 165   printDebug "[triggerSearxSearch] cId" cId
 166   printDebug "[triggerSearxSearch] q" q
 167   printDebug "[triggerSearxSearch] l" l
 168   cfg <- view hasConfig
 169   uId <- getUserId user
 170   let surl = _gc_frame_searx_url cfg
 171   printDebug "[triggerSearxSearch] surl" surl
 172   mListId <- defaultListMaybe cId
 173   listId <- case mListId of
 174     Nothing -> do
 175       listId <- getOrMkList cId uId
 176       pure listId
 177     Just listId -> pure listId
 178
 179   printDebug "[triggerSearxSearch] listId" listId
 180
 181   manager <- liftBase $ newManager tlsManagerSettings
 182   _ <- mapM (\page -> do
 183                 res <- liftBase $ fetchSearxPage $ FetchSearxParams { _fsp_language = l
 184                                                                     , _fsp_manager = manager
 185                                                                     , _fsp_pageno = page
 186                                                                     , _fsp_query = q
 187                                                                     , _fsp_url = surl }
 188
 189                 insertSearxResponse user cId listId l res
 190
 191                 logStatus $ JobLog { _scst_succeeded = Just page
 192                                    , _scst_failed    = Just 0
 193                                    , _scst_remaining = Just (numPages - page)
 194                                    , _scst_events    = Just [] }
 195             ) [1..numPages]
 196   --printDebug "[triggerSearxSearch] res" res
 197
 198   pure $ jobLogSuccess jobLog
 199
 200 hyperdataDocumentFromSearxResult :: Lang -> SearxResult -> Either T.Text HyperdataDocument
 201 hyperdataDocumentFromSearxResult l (SearxResult { _sr_content, _sr_engine, _sr_pubdate, _sr_title }) = do
 202   let mDate = parseTimeM False defaultTimeLocale "%Y-%m-%d %H:%M:%S+0000" (T.unpack _sr_pubdate) :: Maybe Day
 203   let mGregorian = toGregorian <$> mDate
 204   Right HyperdataDocument { _hd_bdd = Just "Searx"
 205                           , _hd_doi = Nothing
 206                           , _hd_url = Nothing
 207                           , _hd_uniqId = Nothing
 208                           , _hd_uniqIdBdd = Nothing
 209                           , _hd_page = Nothing
 210                           , _hd_title = Just _sr_title
 211                           , _hd_authors = Nothing
 212                           , _hd_institutes = Nothing
 213                           , _hd_source = Just _sr_engine
 214                           , _hd_abstract = _sr_content
 215                           , _hd_publication_date = T.pack <$> formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S" <$> mDate
 216                           , _hd_publication_year = fromIntegral <$> sel1 <$> mGregorian
 217                           , _hd_publication_month = sel2 <$> mGregorian
 218                           , _hd_publication_day = sel3 <$> mGregorian
 219                           , _hd_publication_hour = Nothing
 220                           , _hd_publication_minute = Nothing
 221                           , _hd_publication_second = Nothing
 222                           , _hd_language_iso2 = Just $ T.pack $ show l }
 223