src/Gargantext/API/Node/New.hs

   1 {-|
   2 Module      : Gargantext.API.Node.Post
   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 New = Post maybe change the name
  11 Async new node feature
  12
  13 -}
  14
  15 {-# LANGUAGE TemplateHaskell    #-}
  16 {-# LANGUAGE TypeOperators      #-}
  17 {-# OPTIONS_GHC -fno-warn-orphans #-}
  18
  19 {-# LANGUAGE IncoherentInstances #-}
  20 module Gargantext.API.Node.New
  21       where
  22
  23 import Control.Lens hiding (elements, Empty)
  24 import Data.Aeson
  25 import Data.Swagger
  26 import Data.Text (Text)
  27 import GHC.Generics (Generic)
  28 import Servant
  29 import Test.QuickCheck (elements)
  30 import Test.QuickCheck.Arbitrary
  31 import Web.FormUrlEncoded          (FromForm, ToForm)
  32
  33 import Gargantext.API.Admin.EnvTypes (GargJob(..), Env)
  34 import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
  35 import Gargantext.API.Prelude
  36 import Gargantext.Database.Action.Flow.Types
  37 import Gargantext.Database.Action.Node
  38 import Gargantext.Database.Admin.Types.Node
  39 import Gargantext.Database.Prelude
  40 import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..))
  41 import Gargantext.Database.Query.Table.Node.User
  42 import Gargantext.Database.Schema.Node
  43 import Gargantext.Prelude
  44 import Gargantext.Utils.Jobs (serveJobsAPI, MonadJobStatus(..))
  45
  46 ------------------------------------------------------------------------
  47 data PostNode = PostNode { pn_name     :: Text
  48                          , pn_typename :: NodeType}
  49   deriving (Generic)
  50 ------------------------------------------------------------------------
  51 -- TODO unPrefix "pn_" FromJSON, ToJSON, ToSchema, adapt frontend.
  52 instance FromJSON  PostNode
  53 instance ToJSON    PostNode
  54 instance ToSchema  PostNode
  55 instance FromForm  PostNode
  56 instance ToForm    PostNode
  57 instance Arbitrary PostNode where
  58   arbitrary = elements [PostNode "Node test" NodeCorpus]
  59
  60 ------------------------------------------------------------------------
  61 postNode :: HasNodeError err
  62          => UserId
  63          -> NodeId
  64          -> PostNode
  65          -> Cmd err [NodeId]
  66 postNode uId pId (PostNode nodeName nt) = do
  67   nodeUser <- getNodeUser (NodeId uId)
  68   let uId' = nodeUser ^. node_user_id
  69   mkNodeWithParent nt (Just pId) uId' nodeName
  70
  71 ------------------------------------------------------------------------
  72 type PostNodeAsync = Summary "Post Node"
  73    :> "async"
  74    :> AsyncJobs JobLog '[FormUrlEncoded] PostNode JobLog
  75
  76
  77 postNodeAsyncAPI
  78   :: UserId -> NodeId -> ServerT PostNodeAsync (GargM Env GargError)
  79 postNodeAsyncAPI uId nId =
  80   serveJobsAPI NewNodeJob $ \jHandle p -> postNodeAsync uId nId p jHandle
  81
  82 ------------------------------------------------------------------------
  83 postNodeAsync :: (FlowCmdM env err m, MonadJobStatus m)
  84     => UserId
  85     -> NodeId
  86     -> PostNode
  87     -> JobHandle m
  88     -> m ()
  89 postNodeAsync uId nId (PostNode nodeName tn) jobHandle = do
  90
  91   -- printDebug "postNodeAsync" nId
  92   markStarted 3 jobHandle
  93   markProgress 1 jobHandle
  94
  95   nodeUser <- getNodeUser (NodeId uId)
  96
  97   -- _ <- threadDelay 1000
  98   markProgress 1 jobHandle
  99
 100   let uId' = nodeUser ^. node_user_id
 101   _ <- mkNodeWithParent tn (Just nId) uId' nodeName
 102
 103   markComplete jobHandle