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 gp = GroupWithPosTag l CoreNLP HashMap.empty
 140   ngs         <- buildNgramsLists user cId masterCorpusId Nothing gp
 141   _userListId <- flowList_DbRepo listId ngs
 142
 143   pure ()
 144
 145 -- TODO Make an async task out of this?
 146 triggerSearxSearch :: (MonadBase IO m, FlowCmdM env err m)
 147             => User
 148             -> CorpusId
 149             -> API.Query
 150             -> Lang
 151             -> (JobLog -> m ())
 152             -> m JobLog
 153 triggerSearxSearch user cId q l logStatus = do
 154   let numPages = 100
 155   let jobLog = JobLog { _scst_succeeded = Just 0
 156                       , _scst_failed    = Just 0
 157                       , _scst_remaining = Just numPages
 158                       , _scst_events    = Just []
 159                       }
 160   logStatus jobLog
 161
 162   printDebug "[triggerSearxSearch] cId" cId
 163   printDebug "[triggerSearxSearch] q" q
 164   printDebug "[triggerSearxSearch] l" l
 165   cfg <- view hasConfig
 166   uId <- getUserId user
 167   let surl = _gc_frame_searx_url cfg
 168   printDebug "[triggerSearxSearch] surl" surl
 169   mListId <- defaultListMaybe cId
 170   listId <- case mListId of
 171     Nothing -> do
 172       listId <- getOrMkList cId uId
 173       pure listId
 174     Just listId -> pure listId
 175
 176   printDebug "[triggerSearxSearch] listId" listId
 177
 178   manager <- liftBase $ newManager tlsManagerSettings
 179   _ <- mapM (\page -> do
 180                 res <- liftBase $ fetchSearxPage $ FetchSearxParams { _fsp_language = l
 181                                                                     , _fsp_manager = manager
 182                                                                     , _fsp_pageno = page
 183                                                                     , _fsp_query = q
 184                                                                     , _fsp_url = surl }
 185
 186                 insertSearxResponse user cId listId l res
 187
 188                 logStatus $ JobLog { _scst_succeeded = Just page
 189                                    , _scst_failed    = Just 0
 190                                    , _scst_remaining = Just (numPages - page)
 191                                    , _scst_events    = Just [] }
 192             ) [1..numPages]
 193   --printDebug "[triggerSearxSearch] res" res
 194
 195   pure $ jobLogSuccess jobLog
 196
 197 hyperdataDocumentFromSearxResult :: Lang -> SearxResult -> Either T.Text HyperdataDocument
 198 hyperdataDocumentFromSearxResult l (SearxResult { _sr_content, _sr_engine, _sr_pubdate, _sr_title }) = do
 199   let mDate = parseTimeM False defaultTimeLocale "%Y-%m-%d %H:%M:%S+0000" (T.unpack _sr_pubdate) :: Maybe Day
 200   let mGregorian = toGregorian <$> mDate
 201   Right HyperdataDocument { _hd_bdd = Just "Searx"
 202                           , _hd_doi = Nothing
 203                           , _hd_url = Nothing
 204                           , _hd_uniqId = Nothing
 205                           , _hd_uniqIdBdd = Nothing
 206                           , _hd_page = Nothing
 207                           , _hd_title = Just _sr_title
 208                           , _hd_authors = Nothing
 209                           , _hd_institutes = Nothing
 210                           , _hd_source = Just _sr_engine
 211                           , _hd_abstract = _sr_content
 212                           , _hd_publication_date = T.pack <$> formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S" <$> mDate
 213                           , _hd_publication_year = fromIntegral <$> sel1 <$> mGregorian
 214                           , _hd_publication_month = sel2 <$> mGregorian
 215                           , _hd_publication_day = sel3 <$> mGregorian
 216                           , _hd_publication_hour = Nothing
 217                           , _hd_publication_minute = Nothing
 218                           , _hd_publication_second = Nothing
 219                           , _hd_language_iso2 = Just $ T.pack $ show l }
 220