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.API (recomputeGraph)
  33 import Gargantext.Core.Viz.Graph.Tools (PartitionMethod(..), BridgenessMethod(..))
  34 import Gargantext.Core.Viz.Graph.Types (Strength)
  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, (<$>), ($), {-printDebug,-} pure, show, cs, (<>), panic, (<*>))
  47 import Gargantext.Utils.Jobs (serveJobsAPI, MonadJobStatus(..))
  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                                               , methodGraphBridgeness    :: !BridgenessMethod
  67                                               , methodGraphEdgesStrength :: !Strength
  68                                               , methodGraphNodeType1     :: !NgramsType
  69                                               , methodGraphNodeType2     :: !NgramsType
  70                                               }
  71
  72                       | UpdateNodeParamsTexts { methodTexts :: !Granularity }
  73
  74                       | UpdateNodeParamsBoard { methodBoard :: !Charts      }
  75
  76                       | LinkNodeReq           { nodeType    :: !NodeType
  77                                               , id          :: !NodeId }
  78
  79                       | UpdateNodePhylo       { config :: !PhyloSubConfig }
  80     deriving (Generic)
  81
  82 ----------------------------------------------------------------------
  83 data Method = Basic | Advanced | WithModel
  84     deriving (Generic, Eq, Ord, Enum, Bounded)
  85
  86 ----------------------------------------------------------------------
  87 data Granularity = NewNgrams | NewTexts | Both
  88     deriving (Generic, Eq, Ord, Enum, Bounded)
  89
  90 ----------------------------------------------------------------------
  91 data Charts = Sources | Authors | Institutes | Ngrams | All
  92     deriving (Generic, Eq, Ord, Enum, Bounded)
  93
  94 ------------------------------------------------------------------------
  95 api :: UserId -> NodeId -> ServerT API (GargM Env GargError)
  96 api uId nId =
  97   serveJobsAPI UpdateNodeJob $ \jHandle p ->
  98     updateNode uId nId p jHandle
  99
 100 updateNode :: (HasSettings env, FlowCmdM env err m, MonadJobStatus m)
 101     => UserId
 102     -> NodeId
 103     -> UpdateNodeParams
 104     -> JobHandle m
 105     -> m ()
 106 updateNode uId nId (UpdateNodeParamsGraph metric partitionMethod bridgeMethod strength nt1 nt2) jobHandle = do
 107
 108   markStarted 2 jobHandle
 109   -- printDebug "Computing graph: " method
 110   _ <- recomputeGraph uId nId partitionMethod bridgeMethod (Just metric) (Just strength) nt1 nt2 True
 111   -- printDebug "Graph computed: " method
 112   markComplete jobHandle
 113
 114 updateNode _uId nid1 (LinkNodeReq nt nid2) jobHandle = do
 115   markStarted 2 jobHandle
 116   _ <- case nt of
 117     NodeAnnuaire -> pairing nid2 nid1 Nothing -- defaultList
 118     NodeCorpus   -> pairing nid1 nid2 Nothing -- defaultList
 119     _            -> panic $ "[G.API.N.Update.updateNode] NodeType not implemented"
 120                           <> cs (show nt <> " nid1: " <> show nid1 <> " nid2: " <> show nid2)
 121
 122   markComplete jobHandle
 123
 124 -- | `Advanced` to update graphs
 125 updateNode _uId lId (UpdateNodeParamsList Advanced) jobHandle = do
 126   markStarted 3 jobHandle
 127   corpusId <- view node_parent_id <$> getNode lId
 128
 129   markProgress 1 jobHandle
 130
 131   _ <- case corpusId of
 132     Just cId -> do
 133       _ <- Metrics.updatePie cId (Just lId) NgramsTypes.Authors Nothing
 134       _ <- Metrics.updateTree cId (Just lId) NgramsTypes.Institutes MapTerm
 135       _ <- Metrics.updatePie cId (Just lId) NgramsTypes.Sources Nothing
 136       pure ()
 137     Nothing  -> pure ()
 138
 139   markComplete jobHandle
 140
 141 updateNode _uId lId (UpdateNodeParamsList _mode) jobHandle = do
 142   markStarted 3 jobHandle
 143   corpusId <- view node_parent_id <$> getNode lId
 144
 145   markProgress 1 jobHandle
 146
 147   _ <- case corpusId of
 148     Just cId -> do
 149       _ <- reIndexWith cId lId NgramsTerms (Set.singleton MapTerm)
 150       _ <- updateNgramsOccurrences cId (Just lId)
 151       pure ()
 152     Nothing  -> pure ()
 153
 154   markComplete jobHandle
 155
 156 updateNode _userId phyloId (UpdateNodePhylo config) jobHandle = do
 157   markStarted 3 jobHandle
 158
 159   corpusId' <- view node_parent_id <$> getNode phyloId
 160
 161   let corpusId = fromMaybe (panic "") corpusId'
 162
 163   phy <- flowPhyloAPI (subConfig2config config) corpusId
 164
 165   markProgress 1 jobHandle
 166
 167   _ <- updateHyperdata phyloId (HyperdataPhylo Nothing (Just phy))
 168
 169   markComplete jobHandle
 170
 171 updateNode _uId tId (UpdateNodeParamsTexts _mode) jobHandle = do
 172   markStarted 3 jobHandle
 173
 174   corpusId <- view node_parent_id <$> getNode tId
 175   lId      <- defaultList $ fromMaybe (panic "[G.A.N.Update] updateNode/UpdateNodeParamsTexts: no defaultList") corpusId
 176
 177   markProgress 1 jobHandle
 178
 179   _ <- case corpusId of
 180     Just cId -> do
 181       _ <- reIndexWith cId lId NgramsTerms (Set.singleton MapTerm)
 182       _ <- updateNgramsOccurrences cId (Just lId)
 183       _ <- updateContextScore      cId (Just lId)
 184       _ <- Metrics.updateChart     cId (Just lId) NgramsTypes.Docs Nothing
 185       -- printDebug "updateContextsScore" (cId, lId, u)
 186       pure ()
 187     Nothing  -> pure ()
 188
 189   markComplete jobHandle
 190
 191
 192 updateNode _uId _nId _p jobHandle = do
 193   simuLogs jobHandle 10
 194
 195 ------------------------------------------------------------------------
 196 -- TODO unPrefix "pn_" FromJSON, ToJSON, ToSchema, adapt frontend.
 197 instance FromJSON  UpdateNodeParams where
 198   parseJSON = genericParseJSON (defaultOptions { sumEncoding = GUA.defaultTaggedObject })
 199
 200 instance ToJSON    UpdateNodeParams where
 201   toJSON = genericToJSON (defaultOptions { sumEncoding = GUA.defaultTaggedObject })
 202
 203 instance ToSchema  UpdateNodeParams
 204 instance Arbitrary UpdateNodeParams where
 205   arbitrary = do
 206     l <- UpdateNodeParamsList  <$> arbitrary
 207     g <- UpdateNodeParamsGraph <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
 208     t <- UpdateNodeParamsTexts <$> arbitrary
 209     b <- UpdateNodeParamsBoard <$> arbitrary
 210     elements [l,g,t,b]
 211
 212 instance FromJSON  Method
 213 instance ToJSON    Method
 214 instance ToSchema  Method
 215 instance Arbitrary Method where
 216   arbitrary = elements [ minBound .. maxBound ]
 217
 218 instance FromJSON  Granularity
 219 instance ToJSON    Granularity
 220 instance ToSchema  Granularity
 221 instance Arbitrary Granularity where
 222   arbitrary = elements [ minBound .. maxBound ]
 223
 224 instance FromJSON  Charts
 225 instance ToJSON    Charts
 226 instance ToSchema  Charts
 227 instance Arbitrary Charts where
 228   arbitrary = elements [ minBound .. maxBound ]
 229
 230 ------------------------------------------------------------------------