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