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(..))
  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 qualified Gargantext.API.Metrics as Metrics
  27 import Gargantext.API.Ngrams.List (reIndexWith)
  28 import qualified Gargantext.API.Ngrams.Types as NgramsTypes
  29 import Gargantext.API.Prelude (GargServer, simuLogs)
  30 import Gargantext.Core.Methods.Distances (GraphMetric(..))
  31 import Gargantext.Core.Types.Main (ListType(..))
  32 import Gargantext.Core.Viz.Graph.API (recomputeGraph)
  33 import Gargantext.Database.Action.Metrics (updateNgramsOccurrences)
  34 import Gargantext.Database.Action.Flow.Pairing (pairing)
  35 import Gargantext.Database.Action.Flow.Types (FlowCmdM)
  36 import Gargantext.Database.Admin.Types.Node
  37 import Gargantext.Database.Query.Table.Node (getNode)
  38 import Gargantext.Database.Schema.Node (node_parent_id)
  39 import Gargantext.Database.Schema.Ngrams (NgramsType(NgramsTerms))
  40 import Gargantext.Prelude (Bool(..), Ord, Eq, (<$>), ($), liftBase, (.), printDebug, pure, show, cs, (<>), panic)
  41 import qualified Gargantext.Utils.Aeson as GUA
  42 import Prelude (Enum, Bounded, minBound, maxBound)
  43 import Servant
  44 import Servant.Job.Async (JobFunction(..), serveJobsAPI)
  45 import Test.QuickCheck (elements)
  46 import Test.QuickCheck.Arbitrary
  47 import qualified Data.Set as Set
  48
  49 ------------------------------------------------------------------------
  50 type API = Summary " Update node according to NodeType params"
  51          :> AsyncJobs JobLog '[JSON] UpdateNodeParams JobLog
  52
  53 ------------------------------------------------------------------------
  54 data UpdateNodeParams = UpdateNodeParamsList  { methodList  :: !Method      }
  55                       | UpdateNodeParamsGraph { methodGraph :: !GraphMetric }
  56                       | UpdateNodeParamsTexts { methodTexts :: !Granularity }
  57                       | UpdateNodeParamsBoard { methodBoard :: !Charts      }
  58                       | LinkNodeReq { nodeType :: !NodeType, id :: !NodeId }
  59     deriving (Generic)
  60
  61 ----------------------------------------------------------------------
  62 data Method = Basic | Advanced | WithModel
  63     deriving (Generic, Eq, Ord, Enum, Bounded)
  64
  65 ----------------------------------------------------------------------
  66 data Granularity = NewNgrams | NewTexts | Both
  67     deriving (Generic, Eq, Ord, Enum, Bounded)
  68
  69 ----------------------------------------------------------------------
  70 data Charts = Sources | Authors | Institutes | Ngrams | All
  71     deriving (Generic, Eq, Ord, Enum, Bounded)
  72
  73 ------------------------------------------------------------------------
  74 api :: UserId -> NodeId -> GargServer API
  75 api uId nId =
  76   serveJobsAPI $
  77     JobFunction (\p log'' ->
  78       let
  79         log' x = do
  80           printDebug "updateNode" x
  81           liftBase $ log'' x
  82       in updateNode uId nId p (liftBase . log')
  83       )
  84
  85 updateNode :: (HasSettings env, FlowCmdM env err m)
  86     => UserId
  87     -> NodeId
  88     -> UpdateNodeParams
  89     -> (JobLog -> m ())
  90     -> m JobLog
  91 updateNode uId nId (UpdateNodeParamsGraph metric) logStatus = do
  92
  93   logStatus JobLog { _scst_succeeded = Just 1
  94                    , _scst_failed    = Just 0
  95                    , _scst_remaining = Just 1
  96                    , _scst_events    = Just []
  97                    }
  98
  99   _ <- recomputeGraph uId nId (Just metric) True
 100
 101   pure  JobLog { _scst_succeeded = Just 2
 102                , _scst_failed    = Just 0
 103                , _scst_remaining = Just 0
 104                , _scst_events    = Just []
 105                }
 106
 107 updateNode _uId nid1 (LinkNodeReq nt nid2) logStatus = do
 108   logStatus JobLog { _scst_succeeded = Just 1
 109                    , _scst_failed    = Just 0
 110                    , _scst_remaining = Just 1
 111                    , _scst_events    = Just []
 112                    }
 113   _ <- case nt of
 114     NodeAnnuaire -> pairing nid2 nid1 Nothing -- defaultList
 115     NodeCorpus   -> pairing nid1 nid2 Nothing -- defaultList
 116     _            -> panic $ "[G.API.N.Update.updateNode] NodeType not implemented"
 117                            <> cs (show nt)
 118
 119   pure  JobLog { _scst_succeeded = Just 2
 120                , _scst_failed    = Just 0
 121                , _scst_remaining = Just 0
 122                , _scst_events    = Just []
 123                }
 124
 125 -- | `Advanced` to update graphs
 126 updateNode _uId lId (UpdateNodeParamsList Advanced) logStatus = do
 127   logStatus JobLog { _scst_succeeded = Just 1
 128                    , _scst_failed    = Just 0
 129                    , _scst_remaining = Just 2
 130                    , _scst_events    = Just []
 131                    }
 132   corpusId <- view node_parent_id <$> getNode lId
 133
 134   logStatus JobLog { _scst_succeeded = Just 2
 135                    , _scst_failed    = Just 0
 136                    , _scst_remaining = Just 1
 137                    , _scst_events    = Just []
 138                    }
 139
 140   _ <- case corpusId of
 141     Just cId -> do
 142       _ <- Metrics.updatePie' cId (Just lId) NgramsTypes.Authors Nothing
 143       _ <- Metrics.updateTree' cId (Just lId) NgramsTypes.Institutes MapTerm
 144       _ <- Metrics.updatePie' cId (Just lId) NgramsTypes.Sources Nothing
 145       pure ()
 146     Nothing  -> pure ()
 147
 148   pure  JobLog { _scst_succeeded = Just 3
 149                , _scst_failed    = Just 0
 150                , _scst_remaining = Just 0
 151                , _scst_events    = Just []
 152                }
 153
 154 updateNode _uId lId (UpdateNodeParamsList _mode) logStatus = do
 155   logStatus JobLog { _scst_succeeded = Just 1
 156                    , _scst_failed    = Just 0
 157                    , _scst_remaining = Just 2
 158                    , _scst_events    = Just []
 159                    }
 160   corpusId <- view node_parent_id <$> getNode lId
 161
 162   logStatus JobLog { _scst_succeeded = Just 2
 163                    , _scst_failed    = Just 0
 164                    , _scst_remaining = Just 1
 165                    , _scst_events    = Just []
 166                    }
 167
 168   _ <- case corpusId of
 169     Just cId -> do
 170       _ <- reIndexWith cId lId NgramsTerms (Set.singleton MapTerm)
 171       _ <- updateNgramsOccurrences cId (Just lId)
 172       pure ()
 173     Nothing  -> pure ()
 174
 175   pure  JobLog { _scst_succeeded = Just 3
 176                , _scst_failed    = Just 0
 177                , _scst_remaining = Just 0
 178                , _scst_events    = Just []
 179                }
 180
 181
 182 updateNode _uId _nId _p logStatus = do
 183   simuLogs logStatus 10
 184
 185 ------------------------------------------------------------------------
 186 -- TODO unPrefix "pn_" FromJSON, ToJSON, ToSchema, adapt frontend.
 187 instance FromJSON  UpdateNodeParams where
 188   parseJSON = genericParseJSON (defaultOptions { sumEncoding = GUA.defaultTaggedObject })
 189
 190 instance ToJSON    UpdateNodeParams where
 191   toJSON = genericToJSON (defaultOptions { sumEncoding = GUA.defaultTaggedObject })
 192
 193 instance ToSchema  UpdateNodeParams
 194 instance Arbitrary UpdateNodeParams where
 195   arbitrary = do
 196     l <- UpdateNodeParamsList  <$> arbitrary
 197     g <- UpdateNodeParamsGraph <$> arbitrary
 198     t <- UpdateNodeParamsTexts <$> arbitrary
 199     b <- UpdateNodeParamsBoard <$> arbitrary
 200     elements [l,g,t,b]
 201
 202 instance FromJSON  Method
 203 instance ToJSON    Method
 204 instance ToSchema  Method
 205 instance Arbitrary Method where
 206   arbitrary = elements [ minBound .. maxBound ]
 207
 208 instance FromJSON  Granularity
 209 instance ToJSON    Granularity
 210 instance ToSchema  Granularity
 211 instance Arbitrary Granularity where
 212   arbitrary = elements [ minBound .. maxBound ]
 213
 214 instance FromJSON  Charts
 215 instance ToJSON    Charts
 216 instance ToSchema  Charts
 217 instance Arbitrary Charts where
 218   arbitrary = elements [ minBound .. maxBound ]
 219
 220 ------------------------------------------------------------------------