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