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