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.Query.Table.Node
  27 import Gargantext.Database.Query.Table.Node.Error
  28 import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
  29 import Gargantext.Prelude
  30 import Gargantext.Prelude.Crypto.Hash (hash)
  31 import Gargantext.Database.Prelude
  32 import Control.Lens (view)
  33 import Gargantext.Prelude.Config (GargConfig(..))
  34
  35 ------------------------------------------------------------------------
  36 -- | TODO mk all others nodes
  37 mkNodeWithParent :: (HasNodeError err)
  38                  => NodeType
  39                  -> Maybe ParentId
  40                  -> UserId
  41                  -> Name
  42                  -> Cmd err [NodeId]
  43 mkNodeWithParent NodeUser (Just _) _   _    = nodeError UserNoParent
  44
  45 ------------------------------------------------------------------------
  46 -- | MkNode, insert and eventually configure Hyperdata
  47 mkNodeWithParent NodeUser Nothing uId name =
  48   insertNodesWithParentR Nothing [node NodeUser name defaultHyperdataUser Nothing uId]
  49
  50 mkNodeWithParent _ Nothing _ _ = nodeError HasParent
  51 ------------------------------------------------------------------------
  52 mkNodeWithParent NodeFrameWrite i u n =
  53   mkNodeWithParent_ConfigureHyperdata NodeFrameWrite i u n
  54
  55 mkNodeWithParent NodeFrameCalc i u n =
  56   mkNodeWithParent_ConfigureHyperdata NodeFrameCalc i u n
  57
  58 mkNodeWithParent nt (Just pId) uId name  = insertNode nt (Just name) Nothing pId uId
  59 -- mkNodeWithParent _ _ _ _ = errorWith "[G.D.A.Node.mkNodeWithParent] nees parent"
  60
  61
  62 -- | Sugar to create a node, get its NodeId and update its Hyperdata after
  63 mkNodeWithParent_ConfigureHyperdata :: (HasNodeError err)
  64                                     => NodeType
  65                                     -> Maybe ParentId
  66                                     -> UserId
  67                                     -> Name
  68                                     -> Cmd err [NodeId]
  69 mkNodeWithParent_ConfigureHyperdata NodeFrameWrite (Just i) uId name =
  70   mkNodeWithParent_ConfigureHyperdata' NodeFrameWrite (Just i) uId name
  71
  72 mkNodeWithParent_ConfigureHyperdata NodeFrameCalc (Just i) uId name =
  73   mkNodeWithParent_ConfigureHyperdata' NodeFrameCalc (Just i) uId name
  74
  75 mkNodeWithParent_ConfigureHyperdata    _ _ _ _ = nodeError NotImplYet
  76
  77
  78 -- | Function not exposed
  79 mkNodeWithParent_ConfigureHyperdata' :: (HasNodeError err)
  80                                     => NodeType
  81                                     -> Maybe ParentId
  82                                     -> UserId
  83                                     -> Name
  84                                     -> Cmd err [NodeId]
  85 mkNodeWithParent_ConfigureHyperdata' nt (Just i) uId name = do
  86   maybeNodeId <- case nt of
  87      NodeFrameWrite -> insertNode NodeFrameWrite (Just name) Nothing i uId
  88      NodeFrameCalc  -> insertNode NodeFrameCalc  (Just name) Nothing i uId
  89      _              -> nodeError NeedsConfiguration
  90
  91   case maybeNodeId of
  92     []  -> nodeError (DoesNotExist i)
  93     [n] -> do
  94       config <- view hasConfig
  95       u <- case nt of
  96             NodeFrameWrite -> pure $ _gc_frame_write_url config
  97             NodeFrameCalc  -> pure $ _gc_frame_calc_url  config
  98             _              -> nodeError NeedsConfiguration
  99       let
 100         s = _gc_secretkey config
 101         hd = HyperdataFrame u (hash $ s <> (cs $ show n))
 102       _ <- updateHyperdata n hd
 103       pure [n]
 104     (_:_:_)  -> nodeError MkNode
 105 mkNodeWithParent_ConfigureHyperdata' _ _ _ _ = nodeError HasParent
 106