]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/API/Node/Update.hs
Merge branch 'dev-ilike-search-fix' of ssh://gitlab.iscpif.fr:20022/gargantext/haskel...
[gargantext.git] / 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 ------------------------------------------------------------------------