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