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