]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/Database/Action/Node.hs
[ngrams] add r_history %~ mempty to ngrams POST
[gargantext.git] / src / Gargantext / Database / Action / Node.hs
1 {-|
2 Module : Gargantext.Database.Action.Node
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 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
12 {-# OPTIONS_GHC -fno-warn-orphans #-}
13
14 {-# LANGUAGE Arrows #-}
15 {-# LANGUAGE ConstraintKinds #-}
16 {-# LANGUAGE FunctionalDependencies #-}
17 {-# LANGUAGE TemplateHaskell #-}
18 {-# LANGUAGE TypeFamilies #-}
19
20 module Gargantext.Database.Action.Node
21 where
22
23 import Gargantext.Core.Types (Name)
24 import Gargantext.Database.Admin.Types.Hyperdata
25 import Gargantext.Database.Admin.Types.Node
26 import Gargantext.Database.Prelude (Cmd)
27 import Gargantext.Database.Query.Table.Node
28 import Gargantext.Database.Query.Table.Node.Error
29 import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
30 import Gargantext.Prelude
31 import Gargantext.Core.Crypto.Hash (hash)
32 import Gargantext.Database.Prelude
33 import Control.Lens (view)
34 import Gargantext.Config (GargConfig(..))
35
36 ------------------------------------------------------------------------
37 -- | TODO mk all others nodes
38 mkNodeWithParent :: (HasNodeError err)
39 => NodeType
40 -> Maybe ParentId
41 -> UserId
42 -> Name
43 -> Cmd err [NodeId]
44 mkNodeWithParent NodeUser (Just _) _ _ = nodeError UserNoParent
45
46 ------------------------------------------------------------------------
47 -- | MkNode, insert and eventually configure Hyperdata
48 mkNodeWithParent NodeUser Nothing uId name =
49 insertNodesWithParentR Nothing [node NodeUser name defaultHyperdataUser Nothing uId]
50
51 mkNodeWithParent _ Nothing _ _ = nodeError HasParent
52 ------------------------------------------------------------------------
53 mkNodeWithParent NodeFrameWrite i u n =
54 mkNodeWithParent_ConfigureHyperdata NodeFrameWrite i u n
55
56 mkNodeWithParent NodeFrameCalc i u n =
57 mkNodeWithParent_ConfigureHyperdata NodeFrameCalc i u n
58
59 mkNodeWithParent nt (Just pId) uId name = insertNode nt (Just name) Nothing pId uId
60 -- mkNodeWithParent _ _ _ _ = errorWith "[G.D.A.Node.mkNodeWithParent] nees parent"
61
62
63 -- | Sugar to create a node, get its NodeId and update its Hyperdata after
64 mkNodeWithParent_ConfigureHyperdata :: (HasNodeError err)
65 => NodeType
66 -> Maybe ParentId
67 -> UserId
68 -> Name
69 -> Cmd err [NodeId]
70 mkNodeWithParent_ConfigureHyperdata NodeFrameWrite (Just i) uId name =
71 mkNodeWithParent_ConfigureHyperdata' NodeFrameWrite (Just i) uId name
72
73 mkNodeWithParent_ConfigureHyperdata NodeFrameCalc (Just i) uId name =
74 mkNodeWithParent_ConfigureHyperdata' NodeFrameCalc (Just i) uId name
75
76 mkNodeWithParent_ConfigureHyperdata _ _ _ _ = nodeError NotImplYet
77
78
79 -- | Function not exposed
80 mkNodeWithParent_ConfigureHyperdata' :: (HasNodeError err)
81 => NodeType
82 -> Maybe ParentId
83 -> UserId
84 -> Name
85 -> Cmd err [NodeId]
86 mkNodeWithParent_ConfigureHyperdata' nt (Just i) uId name = do
87 maybeNodeId <- case nt of
88 NodeFrameWrite -> insertNode NodeFrameWrite (Just name) Nothing i uId
89 NodeFrameCalc -> insertNode NodeFrameCalc (Just name) Nothing i uId
90 _ -> nodeError NeedsConfiguration
91
92 case maybeNodeId of
93 [] -> nodeError (DoesNotExist i)
94 [n] -> do
95 config <- view hasConfig
96 u <- case nt of
97 NodeFrameWrite -> pure $ _gc_frame_write_url config
98 NodeFrameCalc -> pure $ _gc_frame_calc_url config
99 _ -> nodeError NeedsConfiguration
100 let
101 s = _gc_secretkey config
102 hd = HyperdataFrame u (hash $ s <> (cs $ show n))
103 _ <- updateHyperdata n hd
104 pure [n]
105 (_:_:_) -> nodeError MkNode
106 mkNodeWithParent_ConfigureHyperdata' _ _ _ _ = nodeError HasParent
107