src/Gargantext/API/Node/Update.hs

   1 {-|
   2 Module      : Gargantext.API.Node.Update
   3 Description :
   4 Copyright   : (c) CNRS, 2017-Present
   5 License     : AGPL + CECILL v3
   6 Maintainer  : team@gargantext.org
   7 Stability   : experimental
   8 Portability : POSIX
   9
  10 -}
  11
  12 {-# LANGUAGE TemplateHaskell    #-}
  13 {-# LANGUAGE TypeOperators      #-}
  14 {-# OPTIONS_GHC -fno-warn-orphans #-}
  15
  16 module Gargantext.API.Node.Update
  17       where
  18
  19 import Control.Lens (view)
  20 import Data.Aeson
  21 import Data.Maybe (Maybe(..), fromMaybe)
  22 import Data.Swagger
  23 import GHC.Generics (Generic)
  24 import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
  25 import Gargantext.API.Admin.Types (HasSettings)
  26 import Gargantext.API.Ngrams.List (reIndexWith)
  27 --import Gargantext.API.Ngrams.Types (TabType(..))
  28 import Gargantext.API.Prelude (GargServer, simuLogs)
  29 import Gargantext.Core.Methods.Distances (GraphMetric(..))
  30 import Gargantext.Core.Types.Main (ListType(..))
  31 import Gargantext.Core.Viz.Graph (Strength)
  32 import Gargantext.Core.Viz.Graph.API (recomputeGraph)
  33 import Gargantext.Core.Viz.Graph.Tools (PartitionMethod(..))
  34 import Gargantext.Core.Viz.Phylo (PhyloSubConfig(..), subConfig2config)
  35 import Gargantext.Core.Viz.Phylo.API.Tools (flowPhyloAPI)
  36 import Gargantext.Database.Action.Flow.Pairing (pairing)
  37 import Gargantext.Database.Action.Flow.Types (FlowCmdM)
  38 import Gargantext.Database.Action.Metrics (updateNgramsOccurrences, updateContextScore)
  39 import Gargantext.Database.Admin.Types.Hyperdata
  40 import Gargantext.Database.Admin.Types.Node
  41 import Gargantext.Database.Query.Table.Node (defaultList, getNode)
  42 import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
  43 import Gargantext.Database.Schema.Ngrams (NgramsType(NgramsTerms))
  44 import Gargantext.Database.Schema.Node (node_parent_id)
  45 import Gargantext.Prelude (Bool(..), Ord, Eq, (<$>), ($), liftBase, (.), printDebug, pure, show, cs, (<>), panic, (<*>))
  46 import Prelude (Enum, Bounded, minBound, maxBound)
  47 import Servant
  48 import Servant.Job.Async (JobFunction(..), serveJobsAPI)
  49 import Test.QuickCheck (elements)
  50 import Test.QuickCheck.Arbitrary
  51 import qualified Data.Set                    as Set
  52 import qualified Gargantext.API.Metrics      as Metrics
  53 import qualified Gargantext.API.Ngrams.Types as NgramsTypes
  54 import qualified Gargantext.Utils.Aeson      as GUA
  55
  56 ------------------------------------------------------------------------
  57 type API = Summary " Update node according to NodeType params"
  58          :> AsyncJobs JobLog '[JSON] UpdateNodeParams JobLog
  59
  60 ------------------------------------------------------------------------
  61 data UpdateNodeParams = UpdateNodeParamsList  { methodList  :: !Method      }
  62
  63                       | UpdateNodeParamsGraph { methodGraphMetric        :: !GraphMetric
  64                                               , methodGraphClustering    :: !PartitionMethod
  65                                               , methodGraphEdgesStrength :: !Strength
  66                                               }
  67
  68                       | UpdateNodeParamsTexts { methodTexts :: !Granularity }
  69
  70                       | UpdateNodeParamsBoard { methodBoard :: !Charts      }
  71
  72                       | LinkNodeReq           { nodeType    :: !NodeType
  73                                               , id          :: !NodeId }
  74
  75                       | UpdateNodePhylo       { config :: !PhyloSubConfig }
  76     deriving (Generic)
  77
  78 ----------------------------------------------------------------------
  79 data Method = Basic | Advanced | WithModel
  80     deriving (Generic, Eq, Ord, Enum, Bounded)
  81
  82 ----------------------------------------------------------------------
  83 data Granularity = NewNgrams | NewTexts | Both
  84     deriving (Generic, Eq, Ord, Enum, Bounded)
  85
  86 ----------------------------------------------------------------------
  87 data Charts = Sources | Authors | Institutes | Ngrams | All
  88     deriving (Generic, Eq, Ord, Enum, Bounded)
  89
  90 ------------------------------------------------------------------------
  91 api :: UserId -> NodeId -> GargServer API
  92 api uId nId =
  93   serveJobsAPI $
  94     JobFunction (\p log'' ->
  95       let
  96         log' x = do
  97           printDebug "updateNode" x
  98           liftBase $ log'' x
  99       in updateNode uId nId p (liftBase . log')
 100       )
 101
 102 updateNode :: (HasSettings env, FlowCmdM env err m)
 103     => UserId
 104     -> NodeId
 105     -> UpdateNodeParams
 106     -> (JobLog -> m ())
 107     -> m JobLog
 108 updateNode uId nId (UpdateNodeParamsGraph metric method strength) logStatus = do
 109
 110   logStatus JobLog { _scst_succeeded = Just 1
 111                    , _scst_failed    = Just 0
 112                    , _scst_remaining = Just 1
 113                    , _scst_events    = Just []
 114                    }
 115   printDebug "Computing graph: " method
 116   _ <- recomputeGraph uId nId method (Just metric) (Just strength) True
 117   printDebug "Graph computed: " method
 118
 119   pure  JobLog { _scst_succeeded = Just 2
 120                , _scst_failed    = Just 0
 121                , _scst_remaining = Just 0
 122                , _scst_events    = Just []
 123                }
 124
 125 updateNode _uId nid1 (LinkNodeReq nt nid2) logStatus = do
 126   logStatus JobLog { _scst_succeeded = Just 1
 127                    , _scst_failed    = Just 0
 128                    , _scst_remaining = Just 1
 129                    , _scst_events    = Just []
 130                    }
 131   _ <- case nt of
 132     NodeAnnuaire -> pairing nid2 nid1 Nothing -- defaultList
 133     NodeCorpus   -> pairing nid1 nid2 Nothing -- defaultList
 134     _            -> panic $ "[G.API.N.Update.updateNode] NodeType not implemented"
 135                           <> cs (show nt <> " nid1: " <> show nid1 <> " nid2: " <> show nid2)
 136
 137   pure  JobLog { _scst_succeeded = Just 2
 138                , _scst_failed    = Just 0
 139                , _scst_remaining = Just 0
 140                , _scst_events    = Just []
 141                }
 142
 143 -- | `Advanced` to update graphs
 144 updateNode _uId lId (UpdateNodeParamsList Advanced) logStatus = do
 145   logStatus JobLog { _scst_succeeded = Just 1
 146                    , _scst_failed    = Just 0
 147                    , _scst_remaining = Just 2
 148                    , _scst_events    = Just []
 149                    }
 150   corpusId <- view node_parent_id <$> getNode lId
 151
 152   logStatus JobLog { _scst_succeeded = Just 2
 153                    , _scst_failed    = Just 0
 154                    , _scst_remaining = Just 1
 155                    , _scst_events    = Just []
 156                    }
 157
 158   _ <- case corpusId of
 159     Just cId -> do
 160       _ <- Metrics.updatePie cId (Just lId) NgramsTypes.Authors Nothing
 161       _ <- Metrics.updateTree cId (Just lId) NgramsTypes.Institutes MapTerm
 162       _ <- Metrics.updatePie cId (Just lId) NgramsTypes.Sources Nothing
 163       pure ()
 164     Nothing  -> pure ()
 165
 166   pure  JobLog { _scst_succeeded = Just 3
 167                , _scst_failed    = Just 0
 168                , _scst_remaining = Just 0
 169                , _scst_events    = Just []
 170                }
 171
 172 updateNode _uId lId (UpdateNodeParamsList _mode) logStatus = do
 173   logStatus JobLog { _scst_succeeded = Just 1
 174                    , _scst_failed    = Just 0
 175                    , _scst_remaining = Just 2
 176                    , _scst_events    = Just []
 177                    }
 178   corpusId <- view node_parent_id <$> getNode lId
 179
 180   logStatus JobLog { _scst_succeeded = Just 2
 181                    , _scst_failed    = Just 0
 182                    , _scst_remaining = Just 1
 183                    , _scst_events    = Just []
 184                    }
 185
 186   _ <- case corpusId of
 187     Just cId -> do
 188       _ <- reIndexWith cId lId NgramsTerms (Set.singleton MapTerm)
 189       _ <- updateNgramsOccurrences cId (Just lId)
 190       pure ()
 191     Nothing  -> pure ()
 192
 193   pure  JobLog { _scst_succeeded = Just 3
 194                , _scst_failed    = Just 0
 195                , _scst_remaining = Just 0
 196                , _scst_events    = Just []
 197                }
 198
 199 updateNode _userId phyloId (UpdateNodePhylo config) logStatus = do
 200   logStatus JobLog { _scst_succeeded = Just 1
 201                    , _scst_failed    = Just 0
 202                    , _scst_remaining = Just 2
 203                    , _scst_events    = Just []
 204                    }
 205
 206   corpusId' <- view node_parent_id <$> getNode phyloId
 207
 208   let corpusId = fromMaybe (panic "") corpusId'
 209
 210   phy <- flowPhyloAPI (subConfig2config config) corpusId
 211
 212   logStatus JobLog { _scst_succeeded = Just 2
 213                    , _scst_failed    = Just 0
 214                    , _scst_remaining = Just 1
 215                    , _scst_events    = Just []
 216                    }
 217
 218   _ <- updateHyperdata phyloId (HyperdataPhylo Nothing (Just phy))
 219
 220   pure  JobLog { _scst_succeeded = Just 3
 221                , _scst_failed    = Just 0
 222                , _scst_remaining = Just 0
 223                , _scst_events    = Just []
 224                }
 225
 226
 227 updateNode _uId tId (UpdateNodeParamsTexts _mode) logStatus = do
 228   logStatus JobLog { _scst_succeeded = Just 1
 229                    , _scst_failed    = Just 0
 230                    , _scst_remaining = Just 2
 231                    , _scst_events    = Just []
 232                    }
 233   corpusId <- view node_parent_id <$> getNode tId
 234   lId      <- defaultList $ fromMaybe (panic "[G.A.N.Update] updateNode/UpdateNodeParamsTexts: no defaultList") corpusId
 235
 236   logStatus JobLog { _scst_succeeded = Just 2
 237                    , _scst_failed    = Just 0
 238                    , _scst_remaining = Just 1
 239                    , _scst_events    = Just []
 240                    }
 241
 242   _ <- case corpusId of
 243     Just cId -> do
 244       _ <- reIndexWith cId lId NgramsTerms (Set.singleton MapTerm)
 245       _ <- updateNgramsOccurrences cId (Just lId)
 246       _ <- updateContextScore      cId (Just lId)
 247       _ <- Metrics.updateChart     cId (Just lId) NgramsTypes.Docs Nothing
 248       -- printDebug "updateContextsScore" (cId, lId, u)
 249       pure ()
 250     Nothing  -> pure ()
 251
 252   pure  JobLog { _scst_succeeded = Just 3
 253                , _scst_failed    = Just 0
 254                , _scst_remaining = Just 0
 255                , _scst_events    = Just []
 256                }
 257
 258
 259
 260
 261
 262 updateNode _uId _nId _p logStatus = do
 263   simuLogs logStatus 10
 264
 265 ------------------------------------------------------------------------
 266 -- TODO unPrefix "pn_" FromJSON, ToJSON, ToSchema, adapt frontend.
 267 instance FromJSON  UpdateNodeParams where
 268   parseJSON = genericParseJSON (defaultOptions { sumEncoding = GUA.defaultTaggedObject })
 269
 270 instance ToJSON    UpdateNodeParams where
 271   toJSON = genericToJSON (defaultOptions { sumEncoding = GUA.defaultTaggedObject })
 272
 273 instance ToSchema  UpdateNodeParams
 274 instance Arbitrary UpdateNodeParams where
 275   arbitrary = do
 276     l <- UpdateNodeParamsList  <$> arbitrary
 277     g <- UpdateNodeParamsGraph <$> arbitrary <*> arbitrary <*> arbitrary
 278     t <- UpdateNodeParamsTexts <$> arbitrary
 279     b <- UpdateNodeParamsBoard <$> arbitrary
 280     elements [l,g,t,b]
 281
 282 instance FromJSON  Method
 283 instance ToJSON    Method
 284 instance ToSchema  Method
 285 instance Arbitrary Method where
 286   arbitrary = elements [ minBound .. maxBound ]
 287
 288 instance FromJSON  Granularity
 289 instance ToJSON    Granularity
 290 instance ToSchema  Granularity
 291 instance Arbitrary Granularity where
 292   arbitrary = elements [ minBound .. maxBound ]
 293
 294 instance FromJSON  Charts
 295 instance ToJSON    Charts
 296 instance ToSchema  Charts
 297 instance Arbitrary Charts where
 298   arbitrary = elements [ minBound .. maxBound ]
 299
 300 ------------------------------------------------------------------------