[upload] work towards arbitrary file upload

src/Gargantext/API/Node.hs

@@ -36,6 +36,10 @@ import Data.Maybe
 import Data.Swagger
 import Data.Text (Text())
 import GHC.Generics (Generic)
+import Servant
+import Test.QuickCheck (elements)
+import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
+
 import Gargantext.API.Admin.Auth (withAccess, PathId(..))
 import Gargantext.API.Metrics
 import Gargantext.API.Ngrams (TabType(..), TableNgramsApi, apiNgramsTableCorpus)
@@ -60,9 +64,6 @@ import Gargantext.Database.Query.Table.NodeNode
 import Gargantext.Database.Query.Tree (tree, TreeMode(..))
 import Gargantext.Prelude
 import Gargantext.Viz.Phylo.API (PhyloAPI, phyloAPI)
-import Servant
-import Test.QuickCheck (elements)
-import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
 import qualified Gargantext.API.Node.Share  as Share
 import qualified Gargantext.API.Node.Update as Update
 import qualified Gargantext.API.Search as Search

src/Gargantext/API/Node/Corpus/New.hs

@@ -166,6 +166,20 @@ instance FromJSON NewWithForm where
 instance ToSchema NewWithForm where
   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_wf_")
 
+-------------------------------------------------------
+data NewWithFile = NewWithFile
+  { _wfi_data     :: !Text
+  , _wfi_lang     :: !(Maybe Lang)
+  , _wfi_name     :: !Text
+  } deriving (Eq, Show, Generic)
+
+makeLenses ''NewWithFile
+instance FromForm NewWithFile
+instance FromJSON NewWithFile where
+  parseJSON = genericParseJSON $ jsonOptions "_wfi_"
+instance ToSchema NewWithFile where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_wfi_")
+
 ------------------------------------------------------------------------
 type AsyncJobs event ctI input output =
   AsyncJobsAPI' 'Unsafe 'Safe ctI '[JSON] Maybe event input output
@@ -189,14 +203,6 @@ type AddWithFile = Summary "Add with MultipartData to corpus endpoint"
      :> AsyncJobs JobLog '[JSON] () JobLog
 -}
 
-type AddWithForm = Summary "Add with FormUrlEncoded to corpus endpoint"
-   :> "corpus"
-     :> Capture "corpus_id" CorpusId
-   :> "add"
-   :> "form"
-   :> "async"
-     :> AsyncJobs JobLog '[FormUrlEncoded] NewWithForm JobLog
-
 
 ------------------------------------------------------------------------
 -- TODO WithQuery also has a corpus id
@@ -209,10 +215,10 @@ addToCorpusWithQuery :: FlowCmdM env err m
 addToCorpusWithQuery u cid (WithQuery q dbs l _nid) logStatus = do
   -- TODO ...
   logStatus JobLog { _scst_succeeded = Just 0
-                          , _scst_failed    = Just 0
-                          , _scst_remaining = Just 5
-                          , _scst_events    = Just []
-                          }
+                   , _scst_failed    = Just 0
+                   , _scst_remaining = Just 5
+                   , _scst_events    = Just []
+                   }
   printDebug "addToCorpusWithQuery" (cid, dbs)
   -- TODO add cid
   -- TODO if cid is folder -> create Corpus
@@ -221,19 +227,28 @@ addToCorpusWithQuery u cid (WithQuery q dbs l _nid) logStatus = do
   txts <- mapM (\db  -> getDataText db     (Multi l) q Nothing) [database2origin dbs]
 
   logStatus JobLog { _scst_succeeded = Just 2
-                          , _scst_failed    = Just 0
-                          , _scst_remaining = Just 1
-                          , _scst_events    = Just []
-                          }
+                   , _scst_failed    = Just 0
+                   , _scst_remaining = Just 1
+                   , _scst_events    = Just []
+                   }
 
   cids <- mapM (\txt -> flowDataText u txt (Multi l) cid) txts
   printDebug "corpus id" cids
   -- TODO ...
   pure      JobLog { _scst_succeeded = Just 3
-                          , _scst_failed    = Just 0
-                          , _scst_remaining = Just 0
-                          , _scst_events    = Just []
-                          }
+                   , _scst_failed    = Just 0
+                   , _scst_remaining = Just 0
+                   , _scst_events    = Just []
+                   }
+
+
+type AddWithForm = Summary "Add with FormUrlEncoded to corpus endpoint"
+   :> "corpus"
+     :> Capture "corpus_id" CorpusId
+   :> "add"
+   :> "form"
+   :> "async"
+     :> AsyncJobs JobLog '[FormUrlEncoded] NewWithForm JobLog
 
 addToCorpusWithForm :: FlowCmdM env err m
                     => User
@@ -243,12 +258,13 @@ addToCorpusWithForm :: FlowCmdM env err m
                     -> m JobLog
 addToCorpusWithForm user cid (NewWithForm ft d l _n) logStatus = do
 
-  printDebug "Parsing corpus: " cid
+  printDebug "[addToCorpusWithForm] Parsing corpus: " cid
+  printDebug "[addToCorpusWithForm] fileType" ft
   logStatus JobLog { _scst_succeeded = Just 0
-                          , _scst_failed    = Just 0
-                          , _scst_remaining = Just 2
-                          , _scst_events    = Just []
-                          }
+                   , _scst_failed    = Just 0
+                   , _scst_remaining = Just 2
+                   , _scst_events    = Just []
+                   }
   let
     parse = case ft of
       CSV_HAL   -> Parser.parseFormat Parser.CsvHal
@@ -263,10 +279,10 @@ addToCorpusWithForm user cid (NewWithForm ft d l _n) logStatus = do
 
   printDebug "Parsing corpus finished : " cid
   logStatus JobLog { _scst_succeeded = Just 1
-                          , _scst_failed    = Just 0
-                          , _scst_remaining = Just 1
-                          , _scst_events    = Just []
-                          }
+                   , _scst_failed    = Just 0
+                   , _scst_remaining = Just 1
+                   , _scst_events    = Just []
+                   }
 
 
   printDebug "Starting extraction     : " cid
@@ -278,10 +294,10 @@ addToCorpusWithForm user cid (NewWithForm ft d l _n) logStatus = do
 
   printDebug "Extraction finished   : " cid
   pure      JobLog { _scst_succeeded = Just 2
-                          , _scst_failed    = Just 0
-                          , _scst_remaining = Just 0
-                          , _scst_events    = Just []
-                          }
+                   , _scst_failed    = Just 0
+                   , _scst_remaining = Just 0
+                   , _scst_events    = Just []
+                   }
 
 {-
 addToCorpusWithFile :: FlowCmdM env err m
@@ -307,3 +323,33 @@ addToCorpusWithFile cid input filetype logStatus = do
 -}
 
 
+
+type AddWithFile = Summary "Add with FileUrlEncoded to corpus endpoint"
+   :> "corpus"
+     :> Capture "corpus_id" CorpusId
+   :> "add"
+   :> "file"
+   :> "async"
+     :> AsyncJobs JobLog '[FormUrlEncoded] NewWithFile JobLog
+
+addToCorpusWithFile :: FlowCmdM env err m
+                    => User
+                    -> CorpusId
+                    -> NewWithFile
+                    -> (JobLog -> m ())
+                    -> m JobLog
+addToCorpusWithFile _user cid (NewWithFile _d _l _n) logStatus = do
+
+  printDebug "[addToCorpusWithForm] Uploading file to corpus: " cid
+  logStatus JobLog { _scst_succeeded = Just 0
+                   , _scst_failed    = Just 0
+                   , _scst_remaining = Just 1
+                   , _scst_events    = Just []
+                   }
+
+  printDebug "File upload to corpus finished: " cid
+  pure $ JobLog { _scst_succeeded = Just 1
+                , _scst_failed    = Just 0
+                , _scst_remaining = Just 0
+                , _scst_events    = Just []
+                }

src/Gargantext/API/Node/New.hs

@@ -87,25 +87,25 @@ postNodeAsync uId nId (PostNode nodeName tn) logStatus = do
 
   printDebug "postNodeAsync" nId
   logStatus JobLog { _scst_succeeded = Just 1
-                          , _scst_failed    = Just 0
-                          , _scst_remaining = Just 2
-                          , _scst_events    = Just []
-                          }
+                   , _scst_failed    = Just 0
+                   , _scst_remaining = Just 2
+                   , _scst_events    = Just []
+                   }
 
   nodeUser <- getNodeUser (NodeId uId)
 
   -- _ <- threadDelay 1000
   logStatus JobLog { _scst_succeeded = Just 1
-                          , _scst_failed    = Just 0
-                          , _scst_remaining = Just 2
-                          , _scst_events    = Just []
-                          }
+                   , _scst_failed    = Just 0
+                   , _scst_remaining = Just 2
+                   , _scst_events    = Just []
+                   }
 
   let uId' = nodeUser ^. node_userId
   _ <- mkNodeWithParent tn (Just nId) uId' nodeName
 
   pure      JobLog { _scst_succeeded = Just 3
-                          , _scst_failed    = Just 0
-                          , _scst_remaining = Just 0
-                          , _scst_events    = Just []
-                          }
+                   , _scst_failed    = Just 0
+                   , _scst_remaining = Just 0
+                   , _scst_events    = Just []
+                   }

src/Gargantext/API/Routes.hs

@@ -144,7 +144,8 @@ type GargPrivateAPI' =
                           :> TreeAPI
 
            -- :<|> New.Upload
-           :<|> New.AddWithForm 
+           :<|> New.AddWithForm
+           :<|> New.AddWithFile
            :<|> New.AddWithQuery
 
            -- :<|> "annuaire" :> Annuaire.AddWithForm
@@ -222,6 +223,7 @@ serverPrivateGargAPI' (AuthenticatedUser (NodeId uid))
           <$> PathNode <*> treeAPI
      -- TODO access
      :<|> addCorpusWithForm  (RootId (NodeId uid))
+     :<|> addCorpusWithFile  (RootId (NodeId uid))
      :<|> addCorpusWithQuery (RootId (NodeId uid))
 
      -- :<|> addAnnuaireWithForm
@@ -271,6 +273,16 @@ addCorpusWithForm user cid =
           liftBase $ log x
       in New.addToCorpusWithForm user cid i log')
 
+addCorpusWithFile :: User -> GargServer New.AddWithFile
+addCorpusWithFile user cid =
+  serveJobsAPI $
+    JobFunction (\i log ->
+      let
+        log' x = do
+          printDebug "addToCorpusWithFile" x
+          liftBase $ log x
+      in New.addToCorpusWithFile user cid i log')
+
 addAnnuaireWithForm :: GargServer Annuaire.AddWithForm
 addAnnuaireWithForm cid =
   serveJobsAPI $

src/Gargantext/Database/Admin/Config.hs

@@ -66,6 +66,8 @@ nodeTypeId n =
     NodeDashboard   -> 71
 --    NodeNoteBook    -> 88
 
+    NodeFile        -> 101
+
     NodeFrameWrite  -> 991
     NodeFrameCalc   -> 992
 

src/Gargantext/Database/Admin/Types/Hyperdata.hs

@@ -17,6 +17,7 @@ module Gargantext.Database.Admin.Types.Hyperdata
   , module Gargantext.Database.Admin.Types.Hyperdata.Corpus
   , module Gargantext.Database.Admin.Types.Hyperdata.Dashboard
   , module Gargantext.Database.Admin.Types.Hyperdata.Document
+  , module Gargantext.Database.Admin.Types.Hyperdata.File
   , module Gargantext.Database.Admin.Types.Hyperdata.Folder
   , module Gargantext.Database.Admin.Types.Hyperdata.Frame
   , module Gargantext.Database.Admin.Types.Hyperdata.List
@@ -34,6 +35,7 @@ import Gargantext.Database.Admin.Types.Hyperdata.Contact
 import Gargantext.Database.Admin.Types.Hyperdata.Corpus
 import Gargantext.Database.Admin.Types.Hyperdata.Dashboard
 import Gargantext.Database.Admin.Types.Hyperdata.Document
+import Gargantext.Database.Admin.Types.Hyperdata.File
 import Gargantext.Database.Admin.Types.Hyperdata.Folder
 import Gargantext.Database.Admin.Types.Hyperdata.Frame
 import Gargantext.Database.Admin.Types.Hyperdata.List

src/Gargantext/Database/Admin/Types/Hyperdata/Default.hs

@@ -53,6 +53,8 @@ data DefaultHyperdata =
   | DefaultFrameWrite    HyperdataFrame
   | DefaultFrameCalc     HyperdataFrame
 
+  | DefaultFile          HyperdataFile
+
 instance Hyperdata DefaultHyperdata
 
 instance ToJSON DefaultHyperdata where
@@ -82,6 +84,8 @@ instance ToJSON DefaultHyperdata where
   toJSON (DefaultFrameWrite x) = toJSON x
   toJSON (DefaultFrameCalc  x) = toJSON x
 
+  toJSON (DefaultFile x) = toJSON x
+
 
 defaultHyperdata :: NodeType -> DefaultHyperdata
 defaultHyperdata NodeUser           = DefaultUser    defaultHyperdataUser
@@ -109,3 +113,5 @@ defaultHyperdata NodeDashboard      = DefaultDashboard defaultHyperdataDashboard
 
 defaultHyperdata NodeFrameWrite     = DefaultFrameWrite defaultHyperdataFrame
 defaultHyperdata NodeFrameCalc      = DefaultFrameCalc  defaultHyperdataFrame
+
+defaultHyperdata NodeFile           = DefaultFile defaultHyperdataFile

src/Gargantext/Database/Admin/Types/Hyperdata/File.hs

+{-|
+Module      : Gargantext.Database.Admin.Types.Hyperdata.File
+Description :
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+
+-}
+
+{-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE NoImplicitPrelude          #-}
+{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE RankNTypes                 #-}
+{-# LANGUAGE TemplateHaskell            #-}
+
+module Gargantext.Database.Admin.Types.Hyperdata.File
+  where
+
+import Gargantext.Prelude
+import Gargantext.Database.Admin.Types.Hyperdata.Prelude
+
+------------------------------------------------------------------------
+data HyperdataFile =
+  HyperdataFile { _hff_name     :: !Text
+                , _hff_mime     :: !Text
+                }
+    deriving (Generic)
+
+
+defaultHyperdataFile :: HyperdataFile
+defaultHyperdataFile = HyperdataFile "" ""
+
+------------------------------------------------------------------------
+-- Instances
+------------------------------------------------------------------------
+-- | Specific Gargantext instance
+instance Hyperdata HyperdataFile
+makeLenses ''HyperdataFile
+
+-- | All Json instances
+$(deriveJSON (unPrefix "_hff_") ''HyperdataFile)
+
+-- | Arbitrary instances for tests
+instance Arbitrary HyperdataFile where
+  arbitrary = pure defaultHyperdataFile
+
+instance FromField HyperdataFile
+  where
+    fromField = fromField'
+
+instance QueryRunnerColumnDefault PGJsonb HyperdataFile
+  where
+    queryRunnerColumnDefault = fieldQueryRunnerColumn
+
+instance ToSchema HyperdataFile where
+  declareNamedSchema proxy =
+    genericDeclareNamedSchema (unPrefixSwagger "_hff_") proxy
+    & mapped.schema.description ?~ "File Hyperdata"
+    & mapped.schema.example ?~ toJSON defaultHyperdataFile

src/Gargantext/Database/Admin/Types/Node.hs

@@ -259,6 +259,7 @@ data NodeType = NodeUser
 
               -- Optional Nodes
               | NodeFrameWrite | NodeFrameCalc
+              | NodeFile
 
   deriving (Show, Read, Eq, Generic, Bounded, Enum)
 
@@ -293,6 +294,8 @@ defaultName NodeDashboard     = "Dashboard"
 defaultName NodeFrameWrite    = "Frame Write"
 defaultName NodeFrameCalc     = "Frame Calc"
 
+defaultName NodeFile          = "File"
+
 
 instance FromJSON NodeType
 instance ToJSON NodeType

src/Gargantext/Prelude/Utils.hs

@@ -55,7 +55,7 @@ class ReadFile a where
 
 
 writeFile :: (MonadReader env m, MonadBase IO m, HasSettings env, SaveFile a)
-         => a -> m FilePath
+          => a -> m FilePath
 writeFile a = do
   dataPath <- view (settings . fileFolder) <$> ask
   (fp,fn)  <- liftBase $ (toPath 3) . hash . show <$> newStdGen