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.Orchestrator.Types (JobLog(..), AsyncJobs)
  25 import Gargantext.API.Admin.Types (HasSettings)
  26 import Gargantext.API.Ngrams.List (reIndexWith)
  27 import Gargantext.API.Prelude (GargServer, simuLogs)
  28 import Gargantext.Core.Methods.Distances (GraphMetric(..))
  29 import Gargantext.Core.Types.Main (ListType(..))
  30 import Gargantext.Core.Viz.Graph.API (recomputeGraph)
  31 import Gargantext.Core.Viz.Graph.Tools (PartitionMethod(..))
  32 import Gargantext.Core.Viz.Phylo (PhyloSubConfig(..), subConfig2config)
  33 import Gargantext.Core.Viz.Phylo.API.Tools (flowPhyloAPI)
  34 import Gargantext.Database.Action.Flow.Pairing (pairing)
  35 import Gargantext.Database.Action.Flow.Types (FlowCmdM)
  36 import Gargantext.Database.Action.Metrics (updateNgramsOccurrences, updateContextScore)
  37 import Gargantext.Database.Admin.Types.Hyperdata
  38 import Gargantext.Database.Admin.Types.Node
  39 import Gargantext.Database.Query.Table.Node (defaultList, getNode)
  40 import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
  41 import Gargantext.Database.Schema.Ngrams (NgramsType(NgramsTerms))
  42 import Gargantext.Database.Schema.Node (node_parent_id)
  43 import Gargantext.Prelude (Bool(..), Ord, Eq, (<$>), ($), liftBase, (.), printDebug, pure, show, cs, (<>), panic, (<*>))
  44 import Prelude (Enum, Bounded, minBound, maxBound)
  45 import Servant
  46 import Servant.Job.Async (JobFunction(..), serveJobsAPI)
  47 import Test.QuickCheck (elements)
  48 import Test.QuickCheck.Arbitrary
  49 import qualified Data.Set                    as Set
  50 import qualified Gargantext.API.Metrics      as Metrics
  51 import qualified Gargantext.API.Ngrams.Types as NgramsTypes
  52 import qualified Gargantext.Utils.Aeson      as GUA
  53
  54 ------------------------------------------------------------------------
  55 type API = Summary " Update node according to NodeType params"
  56          :> AsyncJobs JobLog '[JSON] UpdateNodeParams JobLog
  57
  58 ------------------------------------------------------------------------
  59 data UpdateNodeParams = UpdateNodeParamsList  { methodList  :: !Method      }
  60
  61                       | UpdateNodeParamsGraph { methodGraphMetric     :: !GraphMetric
  62                                               , methodGraphClustering :: !PartitionMethod
  63                                               }
  64
  65                       | UpdateNodeParamsTexts { methodTexts :: !Granularity }
  66
  67                       | UpdateNodeParamsBoard { methodBoard :: !Charts      }
  68
  69                       | LinkNodeReq           { nodeType    :: !NodeType
  70                                               , id          :: !NodeId }
  71
  72                       | UpdateNodePhylo       { config :: !PhyloSubConfig }
  73     deriving (Generic)
  74
  75 ----------------------------------------------------------------------
  76 data Method = Basic | Advanced | WithModel
  77     deriving (Generic, Eq, Ord, Enum, Bounded)
  78
  79 ----------------------------------------------------------------------
  80 data Granularity = NewNgrams | NewTexts | Both
  81     deriving (Generic, Eq, Ord, Enum, Bounded)
  82
  83 ----------------------------------------------------------------------
  84 data Charts = Sources | Authors | Institutes | Ngrams | All
  85     deriving (Generic, Eq, Ord, Enum, Bounded)
  86
  87 ------------------------------------------------------------------------
  88 api :: UserId -> NodeId -> GargServer API
  89 api uId nId =
  90   serveJobsAPI $
  91     JobFunction (\p log'' ->
  92       let
  93         log' x = do
  94           printDebug "updateNode" x
  95           liftBase $ log'' x
  96       in updateNode uId nId p (liftBase . log')
  97       )
  98
  99 updateNode :: (HasSettings env, FlowCmdM env err m)
 100     => UserId
 101     -> NodeId
 102     -> UpdateNodeParams
 103     -> (JobLog -> m ())
 104     -> m JobLog
 105 updateNode uId nId (UpdateNodeParamsGraph metric method) logStatus = do
 106
 107   logStatus JobLog { _scst_succeeded = Just 1
 108                    , _scst_failed    = Just 0
 109                    , _scst_remaining = Just 1
 110                    , _scst_events    = Just []
 111                    }
 112
 113   _ <- recomputeGraph uId nId method (Just metric) True
 114
 115   pure  JobLog { _scst_succeeded = Just 2
 116                , _scst_failed    = Just 0
 117                , _scst_remaining = Just 0
 118                , _scst_events    = Just []
 119                }
 120
 121 updateNode _uId nid1 (LinkNodeReq nt nid2) logStatus = do
 122   logStatus JobLog { _scst_succeeded = Just 1
 123                    , _scst_failed    = Just 0
 124                    , _scst_remaining = Just 1
 125                    , _scst_events    = Just []
 126                    }
 127   _ <- case nt of
 128     NodeAnnuaire -> pairing nid2 nid1 Nothing -- defaultList
 129     NodeCorpus   -> pairing nid1 nid2 Nothing -- defaultList
 130     _            -> panic $ "[G.API.N.Update.updateNode] NodeType not implemented"
 131                           <> cs (show nt <> " nid1: " <> show nid1 <> " nid2: " <> show nid2)
 132
 133   pure  JobLog { _scst_succeeded = Just 2
 134                , _scst_failed    = Just 0
 135                , _scst_remaining = Just 0
 136                , _scst_events    = Just []
 137                }
 138
 139 -- | `Advanced` to update graphs
 140 updateNode _uId lId (UpdateNodeParamsList Advanced) logStatus = do
 141   logStatus JobLog { _scst_succeeded = Just 1
 142                    , _scst_failed    = Just 0
 143                    , _scst_remaining = Just 2
 144                    , _scst_events    = Just []
 145                    }
 146   corpusId <- view node_parent_id <$> getNode lId
 147
 148   logStatus JobLog { _scst_succeeded = Just 2
 149                    , _scst_failed    = Just 0
 150                    , _scst_remaining = Just 1
 151                    , _scst_events    = Just []
 152                    }
 153
 154   _ <- case corpusId of
 155     Just cId -> do
 156       _ <- Metrics.updatePie' cId (Just lId) NgramsTypes.Authors Nothing
 157       _ <- Metrics.updateTree' cId (Just lId) NgramsTypes.Institutes MapTerm
 158       _ <- Metrics.updatePie' cId (Just lId) NgramsTypes.Sources Nothing
 159       pure ()
 160     Nothing  -> pure ()
 161
 162   pure  JobLog { _scst_succeeded = Just 3
 163                , _scst_failed    = Just 0
 164                , _scst_remaining = Just 0
 165                , _scst_events    = Just []
 166                }
 167
 168 updateNode _uId lId (UpdateNodeParamsList _mode) logStatus = do
 169   logStatus JobLog { _scst_succeeded = Just 1
 170                    , _scst_failed    = Just 0
 171                    , _scst_remaining = Just 2
 172                    , _scst_events    = Just []
 173                    }
 174   corpusId <- view node_parent_id <$> getNode lId
 175
 176   logStatus JobLog { _scst_succeeded = Just 2
 177                    , _scst_failed    = Just 0
 178                    , _scst_remaining = Just 1
 179                    , _scst_events    = Just []
 180                    }
 181
 182   _ <- case corpusId of
 183     Just cId -> do
 184       _ <- reIndexWith cId lId NgramsTerms (Set.singleton MapTerm)
 185       _ <- updateNgramsOccurrences cId (Just lId)
 186       pure ()
 187     Nothing  -> pure ()
 188
 189   pure  JobLog { _scst_succeeded = Just 3
 190                , _scst_failed    = Just 0
 191                , _scst_remaining = Just 0
 192                , _scst_events    = Just []
 193                }
 194
 195 updateNode _userId phyloId (UpdateNodePhylo config) logStatus = do
 196   logStatus JobLog { _scst_succeeded = Just 1
 197                    , _scst_failed    = Just 0
 198                    , _scst_remaining = Just 2
 199                    , _scst_events    = Just []
 200                    }
 201
 202   corpusId' <- view node_parent_id <$> getNode phyloId
 203
 204   let corpusId = fromMaybe (panic "") corpusId'
 205
 206   phy <- flowPhyloAPI (subConfig2config config) corpusId
 207
 208   logStatus JobLog { _scst_succeeded = Just 2
 209                    , _scst_failed    = Just 0
 210                    , _scst_remaining = Just 1
 211                    , _scst_events    = Just []
 212                    }
 213
 214   _ <- updateHyperdata phyloId (HyperdataPhylo Nothing (Just phy))
 215
 216   pure  JobLog { _scst_succeeded = Just 3
 217                , _scst_failed    = Just 0
 218                , _scst_remaining = Just 0
 219                , _scst_events    = Just []
 220                }
 221
 222
 223 updateNode _uId tId (UpdateNodeParamsTexts _mode) logStatus = do
 224   logStatus JobLog { _scst_succeeded = Just 1
 225                    , _scst_failed    = Just 0
 226                    , _scst_remaining = Just 2
 227                    , _scst_events    = Just []
 228                    }
 229   corpusId <- view node_parent_id <$> getNode tId
 230   lId      <- defaultList $ fromMaybe (panic "[G.A.N.Update] updateNode/UpdateNodeParamsTexts: no defaultList") corpusId
 231
 232   logStatus JobLog { _scst_succeeded = Just 2
 233                    , _scst_failed    = Just 0
 234                    , _scst_remaining = Just 1
 235                    , _scst_events    = Just []
 236                    }
 237
 238   _ <- case corpusId of
 239     Just cId -> do
 240       _ <- reIndexWith cId lId NgramsTerms (Set.singleton MapTerm)
 241       _ <- updateNgramsOccurrences cId (Just lId)
 242       _ <- updateContextScore      cId (Just lId)
 243       -- printDebug "updateContextsScore" (cId, lId, u)
 244       pure ()
 245     Nothing  -> pure ()
 246
 247   pure  JobLog { _scst_succeeded = Just 3
 248                , _scst_failed    = Just 0
 249                , _scst_remaining = Just 0
 250                , _scst_events    = Just []
 251                }
 252
 253
 254
 255
 256
 257 updateNode _uId _nId _p logStatus = do
 258   simuLogs logStatus 10
 259
 260 ------------------------------------------------------------------------
 261 -- TODO unPrefix "pn_" FromJSON, ToJSON, ToSchema, adapt frontend.
 262 instance FromJSON  UpdateNodeParams where
 263   parseJSON = genericParseJSON (defaultOptions { sumEncoding = GUA.defaultTaggedObject })
 264
 265 instance ToJSON    UpdateNodeParams where
 266   toJSON = genericToJSON (defaultOptions { sumEncoding = GUA.defaultTaggedObject })
 267
 268 instance ToSchema  UpdateNodeParams
 269 instance Arbitrary UpdateNodeParams where
 270   arbitrary = do
 271     l <- UpdateNodeParamsList  <$> arbitrary
 272     g <- UpdateNodeParamsGraph <$> arbitrary <*> arbitrary
 273     t <- UpdateNodeParamsTexts <$> arbitrary
 274     b <- UpdateNodeParamsBoard <$> arbitrary
 275     elements [l,g,t,b]
 276
 277 instance FromJSON  Method
 278 instance ToJSON    Method
 279 instance ToSchema  Method
 280 instance Arbitrary Method where
 281   arbitrary = elements [ minBound .. maxBound ]
 282
 283 instance FromJSON  Granularity
 284 instance ToJSON    Granularity
 285 instance ToSchema  Granularity
 286 instance Arbitrary Granularity where
 287   arbitrary = elements [ minBound .. maxBound ]
 288
 289 instance FromJSON  Charts
 290 instance ToJSON    Charts
 291 instance ToSchema  Charts
 292 instance Arbitrary Charts where
 293   arbitrary = elements [ minBound .. maxBound ]
 294
 295 ------------------------------------------------------------------------