Merge branch 'dev-doc-create-endpoint' into 'dev'

Dev doc create endpoint

See merge request gargantext/haskell-gargantext!64

src/Gargantext/API/Node.hs

@@ -46,7 +46,6 @@ import Gargantext.API.Metrics
 import Gargantext.API.Ngrams (TableNgramsApi, apiNgramsTableCorpus)
 import Gargantext.API.Ngrams.Types (TabType(..))
 import Gargantext.API.Node.File
-import Gargantext.API.Node.FrameCalcUpload (FrameCalcUploadAPI, frameCalcUploadAPI)
 import Gargantext.API.Node.New
 import Gargantext.API.Prelude
 import Gargantext.API.Table
@@ -69,6 +68,8 @@ import Gargantext.Database.Query.Tree (tree, TreeMode(..))
 import Gargantext.Prelude
 import Gargantext.Core.Viz.Phylo.Legacy.LegacyAPI (PhyloAPI, phyloAPI)
 import qualified Gargantext.API.Node.DocumentsFromWriteNodes as DocumentsFromWriteNodes
+import qualified Gargantext.API.Node.DocumentUpload as DocumentUpload
+import qualified Gargantext.API.Node.FrameCalcUpload as FrameCalcUpload
 import qualified Gargantext.API.Node.Share  as Share
 import qualified Gargantext.API.Node.Update as Update
 import qualified Gargantext.API.Search as Search
@@ -125,7 +126,7 @@ type NodeAPI a = Get '[JSON] (Node a)
              :<|> "rename" :> RenameApi
              :<|> PostNodeApi -- TODO move to children POST
              :<|> PostNodeAsync
-             :<|> FrameCalcUploadAPI
+             :<|> FrameCalcUpload.API
              :<|> ReqBody '[JSON] a :> Put    '[JSON] Int
              :<|> "update"     :> Update.API
              :<|> Delete '[JSON] Int
@@ -159,6 +160,7 @@ type NodeAPI a = Get '[JSON] (Node a)
              :<|> "async"     :> FileAsyncApi
 
              :<|> "documents-from-write-nodes" :> DocumentsFromWriteNodes.API
+             :<|> DocumentUpload.API
 
 -- TODO-ACCESS: check userId CanRenameNode nodeId
 -- TODO-EVENTS: NodeRenamed RenameNode or re-use some more general NodeEdited...
@@ -210,7 +212,7 @@ nodeAPI p uId id' = withAccess (Proxy :: Proxy (NodeAPI a)) Proxy uId (PathNode
            :<|> rename        id'
            :<|> postNode  uId id'
            :<|> postNodeAsyncAPI  uId id'
-           :<|> frameCalcUploadAPI uId id'
+           :<|> FrameCalcUpload.api uId id'
            :<|> putNode       id'
            :<|> Update.api  uId id'
            :<|> Action.deleteNode (RootId $ NodeId uId) id'
@@ -244,6 +246,7 @@ nodeAPI p uId id' = withAccess (Proxy :: Proxy (NodeAPI a)) Proxy uId (PathNode
            :<|> fileAsyncApi uId id'
 
            :<|> DocumentsFromWriteNodes.api uId id'
+           :<|> DocumentUpload.api uId id'
 
 
 ------------------------------------------------------------------------

src/Gargantext/API/Node/DocumentUpload.hs

+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE MonoLocalBinds      #-}
+{-# LANGUAGE TemplateHaskell     #-}
+{-# LANGUAGE TypeOperators       #-}
+
+module Gargantext.API.Node.DocumentUpload where
+
+import Control.Lens (makeLenses, view)
+import Data.Aeson
+import Data.Swagger (ToSchema)
+import qualified Data.Text as T
+import Data.Time.Clock
+import Data.Time.Calendar
+import GHC.Generics (Generic)
+import Servant
+import Servant.Job.Async
+
+import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
+import Gargantext.API.Job (jobLogSuccess)
+import Gargantext.API.Prelude
+import Gargantext.Core (Lang(..))
+import Gargantext.Core.Text.Terms (TermType(..))
+import Gargantext.Core.Types.Individu (User(..))
+import Gargantext.Core.Utils.Prefix (unCapitalize, dropPrefix)
+import Gargantext.Database.Action.Flow (flowDataText, DataText(..))
+import Gargantext.Database.Action.Flow.Types
+import Gargantext.Database.Admin.Types.Hyperdata.Document (HyperdataDocument(..))
+import Gargantext.Database.Admin.Types.Node
+import Gargantext.Database.Query.Table.Node (getClosestParentIdByType')
+import Gargantext.Prelude
+
+data DocumentUpload = DocumentUpload
+  { _du_abstract :: T.Text
+  , _du_authors  :: T.Text
+  , _du_sources  :: T.Text
+  , _du_title    :: T.Text }
+  deriving (Generic)
+
+$(makeLenses ''DocumentUpload)
+
+instance ToSchema DocumentUpload
+instance FromJSON DocumentUpload
+  where
+    parseJSON = genericParseJSON
+            ( defaultOptions { sumEncoding = ObjectWithSingleField 
+                            , fieldLabelModifier = unCapitalize . dropPrefix "_du_"
+                            , omitNothingFields = True
+                            }
+            )
+instance ToJSON DocumentUpload
+  where
+    toJSON = genericToJSON
+           ( defaultOptions { sumEncoding = ObjectWithSingleField 
+                            , fieldLabelModifier = unCapitalize . dropPrefix "_du_"
+                            , omitNothingFields = True
+                            }
+           )
+
+type API = Summary " Document upload"
+           :> "document"
+           :> "upload"
+           :> "async"
+           :> AsyncJobs JobLog '[JSON] DocumentUpload JobLog
+
+api :: UserId -> NodeId -> GargServer API
+api uId nId =
+  serveJobsAPI $
+    JobFunction (\q log' -> do
+      documentUpload uId nId q (liftBase . log')
+    )
+
+documentUpload :: (FlowCmdM env err m)
+               => UserId
+               -> NodeId
+               -> DocumentUpload
+               -> (JobLog -> m ())
+               -> m JobLog
+documentUpload uId nId doc logStatus = do
+  let jl = JobLog { _scst_succeeded = Just 0
+                  , _scst_failed    = Just 0
+                  , _scst_remaining = Just 1
+                  , _scst_events    = Just [] }
+  logStatus jl
+  
+  mcId <- getClosestParentIdByType' nId NodeCorpus
+  let cId = case mcId of
+        Just c  -> c
+        Nothing -> panic $ T.pack $ "[G.A.N.DU] Node has no corpus parent: " <> show nId
+
+  (year, month, day) <- liftBase $ getCurrentTime >>= return . toGregorian . utctDay
+  let nowS = T.pack $ show year <> "-" <> show month <> "-" <> show day
+  
+  let hd = HyperdataDocument { _hd_bdd = Nothing
+                             , _hd_doi = Nothing
+                             , _hd_url = Nothing
+                             , _hd_uniqId = Nothing
+                             , _hd_uniqIdBdd = Nothing
+                             , _hd_page = Nothing
+                             , _hd_title = Just $ view du_title doc
+                             , _hd_authors = Just $ view du_authors doc
+                             , _hd_institutes = Nothing
+                             , _hd_source = Just $ view du_sources doc
+                             , _hd_abstract = Just $ view du_abstract doc
+                             , _hd_publication_date = Just nowS
+                             , _hd_publication_year = Just $ fromIntegral year
+                             , _hd_publication_month = Just month
+                             , _hd_publication_day = Just day
+                             , _hd_publication_hour = Nothing
+                             , _hd_publication_minute = Nothing
+                             , _hd_publication_second = Nothing
+                             , _hd_language_iso2 = Just $ T.pack $ show EN }
+  
+  _ <- flowDataText (RootId (NodeId uId)) (DataNew [[hd]]) (Multi EN) cId Nothing
+
+  pure $ jobLogSuccess jl

src/Gargantext/API/Node/DocumentsFromWriteNodes.hs

@@ -12,7 +12,6 @@ Portability : POSIX
 {-# LANGUAGE MonoLocalBinds     #-}
 {-# LANGUAGE TemplateHaskell    #-}
 {-# LANGUAGE TypeOperators      #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Gargantext.API.Node.DocumentsFromWriteNodes
       where
@@ -24,6 +23,7 @@ import Data.Swagger
 import qualified Data.Text as T
 import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
 import Gargantext.API.Admin.Types (HasSettings)
+import Gargantext.API.Job (jobLogSuccess, jobLogFailTotalWithMessage)
 import Gargantext.API.Prelude (GargServer)
 import Gargantext.Core (Lang(..))
 import Gargantext.Core.Text.Corpus.Parsers.FrameWrite
@@ -71,15 +71,20 @@ documentsFromWriteNodes :: (HasSettings env, FlowCmdM env err m)
     -> (JobLog -> m ())
     -> m JobLog
 documentsFromWriteNodes uId nId _p logStatus = do
-
-  logStatus JobLog { _scst_succeeded = Just 1
-                   , _scst_failed    = Just 0
-                   , _scst_remaining = Just 1
-                   , _scst_events    = Just []
-                   }
+  let jobLog = JobLog { _scst_succeeded = Just 1
+                      , _scst_failed    = Just 0
+                      , _scst_remaining = Just 1
+                      , _scst_events    = Just []
+                      }
+  logStatus jobLog
 
   mcId <- getClosestParentIdByType' nId NodeCorpus
-  let cId = maybe (panic "[G.A.N.DFWN] Node has no parent") identity mcId
+  cId <- case mcId of
+    Just cId -> pure cId
+    Nothing -> do
+      let msg = T.pack $ "[G.A.N.DFWN] Node has no corpus parent: " <> show nId
+      logStatus $ jobLogFailTotalWithMessage msg jobLog
+      panic msg
 
   frameWriteIds <- getChildrenByType nId NodeFrameWrite
 
@@ -97,11 +102,7 @@ documentsFromWriteNodes uId nId _p logStatus = do
 
   _ <- flowDataText (RootId (NodeId uId)) (DataNew [parsed]) (Multi EN) cId Nothing
 
-  pure  JobLog { _scst_succeeded = Just 2
-               , _scst_failed    = Just 0
-               , _scst_remaining = Just 0
-               , _scst_events    = Just []
-               }
+  pure $ jobLogSuccess jobLog
 ------------------------------------------------------------------------
 hyperdataDocumentFromFrameWrite :: (HyperdataFrame, T.Text) -> Either T.Text HyperdataDocument
 hyperdataDocumentFromFrameWrite (HyperdataFrame { _hf_base, _hf_frame_id }, contents) =

src/Gargantext/API/Node/FrameCalcUpload.hs

@@ -40,14 +40,14 @@ instance FromJSON FrameCalcUpload
 instance ToJSON FrameCalcUpload
 instance ToSchema FrameCalcUpload
 
-type FrameCalcUploadAPI = Summary " FrameCalc upload"
-                        :> "add"
-                        :> "framecalc"
-                        :> "async"
-                        :> AsyncJobs JobLog '[JSON] FrameCalcUpload JobLog
-
-frameCalcUploadAPI :: UserId -> NodeId -> GargServer FrameCalcUploadAPI
-frameCalcUploadAPI uId nId =
+type API = Summary " FrameCalc upload"
+           :> "add"
+           :> "framecalc"
+           :> "async"
+           :> AsyncJobs JobLog '[JSON] FrameCalcUpload JobLog
+
+api :: UserId -> NodeId -> GargServer API
+api uId nId =
   serveJobsAPI $ 
     JobFunction (\p logs ->
                    frameCalcUploadAsync uId nId p (liftBase . logs) (jobLogInit 5)

src/Gargantext/API/Swagger.hs

+{-# OPTIONS_GHC -freduction-depth=400 #-}
+
 {-|
 Module      : Gargantext.API.Swagger
 Description : Swagger API generation