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, (<$>), ($), liftBase, (.), {-printDebug,-} pure, show, cs, (<>), panic, (<*>))
  47 import Gargantext.Utils.Jobs (serveJobsAPI)
  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 $ \p log'' ->
  98       let
  99         log' x = do
 100           -- printDebug "updateNode" x
 101           liftBase $ log'' x
 102       in updateNode uId nId p (liftBase . log')
 103
 104 updateNode :: (HasSettings env, FlowCmdM env err m)
 105     => UserId
 106     -> NodeId
 107     -> UpdateNodeParams
 108     -> (JobLog -> m ())
 109     -> m JobLog
 110 updateNode uId nId (UpdateNodeParamsGraph metric partitionMethod bridgeMethod strength nt1 nt2) logStatus = do
 111
 112   logStatus JobLog { _scst_succeeded = Just 1
 113                    , _scst_failed    = Just 0
 114                    , _scst_remaining = Just 1
 115                    , _scst_events    = Just []
 116                    }
 117   -- printDebug "Computing graph: " method
 118   _ <- recomputeGraph uId nId partitionMethod bridgeMethod (Just metric) (Just strength) nt1 nt2 True
 119   -- printDebug "Graph computed: " method
 120
 121   pure  JobLog { _scst_succeeded = Just 2
 122                , _scst_failed    = Just 0
 123                , _scst_remaining = Just 0
 124                , _scst_events    = Just []
 125                }
 126
 127 updateNode _uId nid1 (LinkNodeReq nt nid2) logStatus = do
 128   logStatus JobLog { _scst_succeeded = Just 1
 129                    , _scst_failed    = Just 0
 130                    , _scst_remaining = Just 1
 131                    , _scst_events    = Just []
 132                    }
 133   _ <- case nt of
 134     NodeAnnuaire -> pairing nid2 nid1 Nothing -- defaultList
 135     NodeCorpus   -> pairing nid1 nid2 Nothing -- defaultList
 136     _            -> panic $ "[G.API.N.Update.updateNode] NodeType not implemented"
 137                           <> cs (show nt <> " nid1: " <> show nid1 <> " nid2: " <> show nid2)
 138
 139   pure  JobLog { _scst_succeeded = Just 2
 140                , _scst_failed    = Just 0
 141                , _scst_remaining = Just 0
 142                , _scst_events    = Just []
 143                }
 144
 145 -- | `Advanced` to update graphs
 146 updateNode _uId lId (UpdateNodeParamsList Advanced) logStatus = do
 147   logStatus JobLog { _scst_succeeded = Just 1
 148                    , _scst_failed    = Just 0
 149                    , _scst_remaining = Just 2
 150                    , _scst_events    = Just []
 151                    }
 152   corpusId <- view node_parent_id <$> getNode lId
 153
 154   logStatus JobLog { _scst_succeeded = Just 2
 155                    , _scst_failed    = Just 0
 156                    , _scst_remaining = Just 1
 157                    , _scst_events    = Just []
 158                    }
 159
 160   _ <- case corpusId of
 161     Just cId -> do
 162       _ <- Metrics.updatePie cId (Just lId) NgramsTypes.Authors Nothing
 163       _ <- Metrics.updateTree cId (Just lId) NgramsTypes.Institutes MapTerm
 164       _ <- Metrics.updatePie cId (Just lId) NgramsTypes.Sources Nothing
 165       pure ()
 166     Nothing  -> pure ()
 167
 168   pure  JobLog { _scst_succeeded = Just 3
 169                , _scst_failed    = Just 0
 170                , _scst_remaining = Just 0
 171                , _scst_events    = Just []
 172                }
 173
 174 updateNode _uId lId (UpdateNodeParamsList _mode) logStatus = do
 175   logStatus JobLog { _scst_succeeded = Just 1
 176                    , _scst_failed    = Just 0
 177                    , _scst_remaining = Just 2
 178                    , _scst_events    = Just []
 179                    }
 180   corpusId <- view node_parent_id <$> getNode lId
 181
 182   logStatus JobLog { _scst_succeeded = Just 2
 183                    , _scst_failed    = Just 0
 184                    , _scst_remaining = Just 1
 185                    , _scst_events    = Just []
 186                    }
 187
 188   _ <- case corpusId of
 189     Just cId -> do
 190       _ <- reIndexWith cId lId NgramsTerms (Set.singleton MapTerm)
 191       _ <- updateNgramsOccurrences cId (Just lId)
 192       pure ()
 193     Nothing  -> pure ()
 194
 195   pure  JobLog { _scst_succeeded = Just 3
 196                , _scst_failed    = Just 0
 197                , _scst_remaining = Just 0
 198                , _scst_events    = Just []
 199                }
 200
 201 updateNode _userId phyloId (UpdateNodePhylo config) logStatus = do
 202   logStatus JobLog { _scst_succeeded = Just 1
 203                    , _scst_failed    = Just 0
 204                    , _scst_remaining = Just 2
 205                    , _scst_events    = Just []
 206                    }
 207
 208   corpusId' <- view node_parent_id <$> getNode phyloId
 209
 210   let corpusId = fromMaybe (panic "") corpusId'
 211
 212   phy <- flowPhyloAPI (subConfigAPI2config config) corpusId
 213
 214   logStatus JobLog { _scst_succeeded = Just 2
 215                    , _scst_failed    = Just 0
 216                    , _scst_remaining = Just 1
 217                    , _scst_events    = Just []
 218                    }
 219
 220   _ <- updateHyperdata phyloId (HyperdataPhylo Nothing (Just phy))
 221
 222   pure  JobLog { _scst_succeeded = Just 3
 223                , _scst_failed    = Just 0
 224                , _scst_remaining = Just 0
 225                , _scst_events    = Just []
 226                }
 227
 228
 229 updateNode _uId tId (UpdateNodeParamsTexts _mode) logStatus = do
 230   logStatus JobLog { _scst_succeeded = Just 1
 231                    , _scst_failed    = Just 0
 232                    , _scst_remaining = Just 2
 233                    , _scst_events    = Just []
 234                    }
 235   corpusId <- view node_parent_id <$> getNode tId
 236   lId      <- defaultList $ fromMaybe (panic "[G.A.N.Update] updateNode/UpdateNodeParamsTexts: no defaultList") corpusId
 237
 238   logStatus JobLog { _scst_succeeded = Just 2
 239                    , _scst_failed    = Just 0
 240                    , _scst_remaining = Just 1
 241                    , _scst_events    = Just []
 242                    }
 243
 244   _ <- case corpusId of
 245     Just cId -> do
 246       _ <- reIndexWith cId lId NgramsTerms (Set.singleton MapTerm)
 247       _ <- updateNgramsOccurrences cId (Just lId)
 248       _ <- updateContextScore      cId (Just lId)
 249       _ <- Metrics.updateChart     cId (Just lId) NgramsTypes.Docs Nothing
 250       -- printDebug "updateContextsScore" (cId, lId, u)
 251       pure ()
 252     Nothing  -> pure ()
 253
 254   pure  JobLog { _scst_succeeded = Just 3
 255                , _scst_failed    = Just 0
 256                , _scst_remaining = Just 0
 257                , _scst_events    = Just []
 258                }
 259
 260
 261
 262
 263
 264 updateNode _uId _nId _p logStatus = do
 265   simuLogs logStatus 10
 266
 267 ------------------------------------------------------------------------
 268 -- TODO unPrefix "pn_" FromJSON, ToJSON, ToSchema, adapt frontend.
 269 instance FromJSON  UpdateNodeParams where
 270   parseJSON = genericParseJSON (defaultOptions { sumEncoding = GUA.defaultTaggedObject })
 271
 272 instance ToJSON    UpdateNodeParams where
 273   toJSON = genericToJSON (defaultOptions { sumEncoding = GUA.defaultTaggedObject })
 274
 275 instance ToSchema  UpdateNodeParams
 276 instance Arbitrary UpdateNodeParams where
 277   arbitrary = do
 278     l <- UpdateNodeParamsList  <$> arbitrary
 279     g <- UpdateNodeParamsGraph <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
 280     t <- UpdateNodeParamsTexts <$> arbitrary
 281     b <- UpdateNodeParamsBoard <$> arbitrary
 282     elements [l,g,t,b]
 283
 284 instance FromJSON  Method
 285 instance ToJSON    Method
 286 instance ToSchema  Method
 287 instance Arbitrary Method where
 288   arbitrary = elements [ minBound .. maxBound ]
 289
 290 instance FromJSON  Granularity
 291 instance ToJSON    Granularity
 292 instance ToSchema  Granularity
 293 instance Arbitrary Granularity where
 294   arbitrary = elements [ minBound .. maxBound ]
 295
 296 instance FromJSON  Charts
 297 instance ToJSON    Charts
 298 instance ToSchema  Charts
 299 instance Arbitrary Charts where
 300   arbitrary = elements [ minBound .. maxBound ]
 301
 302 ------------------------------------------------------------------------