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