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