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