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   corpusId' <- view node_parent_id <$> getNode phyloId
 159   let corpusId = fromMaybe (panic "UpdateNodePhylo: no corpusId") corpusId'
 160   let config'  = subConfig2config config
 161   printDebug "UpdateNodePhylo" config'
 162   phy <- flowPhyloAPI config' corpusId
 163   markProgress 1 jobHandle
 164   _ <- updateHyperdata phyloId (HyperdataPhylo Nothing (Just phy))
 165   markComplete jobHandle
 166
 167 updateNode _uId tId (UpdateNodeParamsTexts _mode) jobHandle = do
 168   markStarted 3 jobHandle
 169   corpusId <- view node_parent_id <$> getNode tId
 170   lId      <- defaultList $ fromMaybe (panic "[G.A.N.Update] updateNode/UpdateNodeParamsTexts: no defaultList") corpusId
 171   markProgress 1 jobHandle
 172
 173   _ <- case corpusId of
 174     Just cId -> do
 175       _ <- reIndexWith cId lId NgramsTerms (Set.singleton MapTerm)
 176       _ <- updateNgramsOccurrences cId (Just lId)
 177       _ <- updateContextScore      cId (Just lId)
 178       _ <- Metrics.updateChart     cId (Just lId) NgramsTypes.Docs Nothing
 179       -- printDebug "updateContextsScore" (cId, lId, u)
 180       pure ()
 181     Nothing  -> pure ()
 182
 183   markComplete jobHandle
 184
 185
 186 updateNode _uId _nId _p jobHandle = do
 187   simuLogs jobHandle 10
 188
 189 ------------------------------------------------------------------------
 190 -- TODO unPrefix "pn_" FromJSON, ToJSON, ToSchema, adapt frontend.
 191 instance FromJSON  UpdateNodeParams where
 192   parseJSON = genericParseJSON (defaultOptions { sumEncoding = GUA.defaultTaggedObject })
 193
 194 instance ToJSON    UpdateNodeParams where
 195   toJSON = genericToJSON (defaultOptions { sumEncoding = GUA.defaultTaggedObject })
 196
 197 instance ToSchema  UpdateNodeParams
 198 instance Arbitrary UpdateNodeParams where
 199   arbitrary = do
 200     l <- UpdateNodeParamsList  <$> arbitrary
 201     g <- UpdateNodeParamsGraph <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
 202     t <- UpdateNodeParamsTexts <$> arbitrary
 203     b <- UpdateNodeParamsBoard <$> arbitrary
 204     elements [l,g,t,b]
 205
 206 instance FromJSON  Method
 207 instance ToJSON    Method
 208 instance ToSchema  Method
 209 instance Arbitrary Method where
 210   arbitrary = elements [ minBound .. maxBound ]
 211
 212 instance FromJSON  Granularity
 213 instance ToJSON    Granularity
 214 instance ToSchema  Granularity
 215 instance Arbitrary Granularity where
 216   arbitrary = elements [ minBound .. maxBound ]
 217
 218 instance FromJSON  Charts
 219 instance ToJSON    Charts
 220 instance ToSchema  Charts
 221 instance Arbitrary Charts where
 222   arbitrary = elements [ minBound .. maxBound ]
 223
 224 ------------------------------------------------------------------------