[FIX] TextFlow insertDB done

bin/gargantext-server/Main.hs

@@ -14,6 +14,7 @@ Script to start gargantext with different modes (Dev, Prod, Mock).
 {-# LANGUAGE StandaloneDeriving   #-}
 {-# LANGUAGE TypeOperators        #-}
 {-# LANGUAGE Strict               #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Main where
 

package.yaml

@@ -211,6 +211,7 @@ library:
   - servant-xml
   - simple-reflect
   - singletons # (IGraph)
+  - template-haskell
   - wai-app-static
 
     # for mail

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

@@ -15,6 +15,7 @@ Main exports of Gargantext:
 
 {-# LANGUAGE TemplateHaskell   #-}
 {-# LANGUAGE TypeOperators     #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Gargantext.API.Node.Corpus.Export
   where
@@ -80,6 +81,9 @@ instance ToSchema Document where
 instance ToSchema Ngrams where
   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_ng_")
 
+instance (ToSchema a) => ToSchema (Node a) where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_node_")
+
 -------
 instance ToParamSchema Corpus where
   toParamSchema _ = toParamSchema (Proxy :: Proxy TODO)

src/Gargantext/Core/Flow/Types.hs

@@ -14,13 +14,13 @@ Portability : POSIX
 
 module Gargantext.Core.Flow.Types where
 
-import Control.Lens (Lens')
+import Control.Lens -- (Lens')
 import Data.Map (Map)
 import Data.Maybe (Maybe)
--- import Control.Applicative
 import Gargantext.Core.Text (HasText(..))
 import Gargantext.Database.Admin.Types.Hyperdata
 import Gargantext.Database.Admin.Types.Node
+import Gargantext.Database.Schema.Node (node_hash_id)
 import Gargantext.Database.Schema.Ngrams (Ngrams, NgramsType)
 import Gargantext.Prelude
 import Gargantext.Prelude.Crypto.Hash (Hash)
@@ -37,6 +37,10 @@ instance UniqId HyperdataContact
   where
     uniqId = hc_uniqId
 
+instance UniqId (Node a)
+  where
+    uniqId = node_hash_id
+
 data DocumentIdWithNgrams a = DocumentIdWithNgrams
   { documentWithId  :: !(DocumentWithId a)
   , documentNgrams :: !(Map Ngrams (Map NgramsType Int))

src/Gargantext/Core/Text/Terms.hs

@@ -105,9 +105,8 @@ withLang (Unsupervised l n s m) ns = Unsupervised l n s m'
                                    )
       just_m -> just_m
 withLang l _ = l
-------------------------------------------------------------------------
-
 
+------------------------------------------------------------------------
 class ExtractNgramsT h
   where
     extractNgramsT :: HasText h

src/Gargantext/Database/Action/Flow.hs

@@ -49,11 +49,10 @@ import Data.Either
 import Data.List (concat)
 import qualified Data.Map as Map
 import Data.Map (Map, lookup)
-import Data.Maybe (Maybe(..), catMaybes, fromMaybe)
+import Data.Maybe (Maybe(..), catMaybes)
 import Data.Monoid
 import Data.Swagger
 import Data.Text (splitOn, intercalate)
-import Data.Time.Segment (jour)
 import Data.Traversable (traverse)
 import Data.Tuple.Extra (first, second)
 import GHC.Generics (Generic)
@@ -71,7 +70,7 @@ import Gargantext.Database.Query.Table.Node
 import Gargantext.Database.Query.Table.Node.Document.Insert -- (insertDocuments, ReturnId(..), addUniqIdsDoc, addUniqIdsContact, ToDbData(..))
 import Gargantext.Database.Query.Tree.Root (getOrMkRoot, getOrMk_RootWithCorpus)
 import Gargantext.Database.Action.Search (searchDocInDatabase)
-import Gargantext.Database.Admin.Config (userMaster, corpusMasterName, nodeTypeId)
+import Gargantext.Database.Admin.Config (userMaster, corpusMasterName)
 import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..))
 import Gargantext.Database.Admin.Types.Hyperdata
 import Gargantext.Database.Admin.Types.Node -- (HyperdataDocument(..), NodeType(..), NodeId, UserId, ListId, CorpusId, RootId, MasterCorpusId, MasterUserId)
@@ -92,7 +91,6 @@ import Gargantext.Core.Text.Terms.Mono.Stem.En (stemIt)
 import Gargantext.Core.Text.Terms
 import qualified Gargantext.Database.Query.Table.Node.Document.Add  as Doc  (add)
 import qualified Gargantext.Core.Text.Corpus.API as API
-import qualified Data.Text as DT
 
 ------------------------------------------------------------------------
 -- TODO use internal with API name (could be old data)
@@ -210,8 +208,8 @@ flowCorpusUser l user corpusName ctype ids = do
   -- TODO: check if present already, ignore
   _ <- Doc.add userCorpusId ids
 
-  tId <- insertDefaultNode NodeTexts userCorpusId userId
-  printDebug "Node Text Ids:" tId
+  _tId <- insertDefaultNode NodeTexts userCorpusId userId
+  -- printDebug "Node Text Ids:" tId
 
   -- User List Flow
   (masterUserId, _masterRootId, masterCorpusId) <- getOrMk_RootWithCorpus (UserName userMaster) (Left "") ctype
@@ -230,7 +228,8 @@ flowCorpusUser l user corpusName ctype ids = do
 
 -- TODO Type NodeDocumentUnicised
 insertDocs :: ( FlowCmdM env err m
-              , FlowCorpus a
+              -- , FlowCorpus a
+              , FlowInsertDB a
               )
               => UserId
               -> CorpusId
@@ -246,19 +245,6 @@ insertDocs uId cId hs = do
   _ <- Doc.add cId newIds'
   pure (newIds', documentsWithId)
 
-{-
--- TODO Maybe NodeId
-toNode :: Hyperdata a => NodeType -> ParentId -> UserId -> a -> Node a
-toNode NodeDocument p u h = Node 0 "" (nodeTypeId nt) u (Just p) n date h
-  where
-    n    = maybe "No Title" (DT.take 255) (_hd_title h)
-    date  = jour y m d
-    y = maybe 0 fromIntegral $ _hd_publication_year  h
-    m = fromMaybe 1 $ _hd_publication_month h
-    d = fromMaybe 1 $ _hd_publication_day   h
-toNode _ _ _ _ = undefined
--}
-
 
 insertMasterDocs :: ( FlowCmdM env err m
                     , FlowCorpus a
@@ -270,8 +256,7 @@ insertMasterDocs :: ( FlowCmdM env err m
                  -> m [DocId]
 insertMasterDocs c lang hs  =  do
   (masterUserId, _, masterCorpusId) <- getOrMk_RootWithCorpus (UserName userMaster) (Left corpusMasterName) c
-  (ids', documentsWithId) <- insertDocs masterUserId masterCorpusId hs
-  -- (ids', documentsWithId) <- insertDocs masterUserId masterCorpusId (map (toNode NodeDocument masterCorpusId masterUserId ) hs )
+  (ids', documentsWithId) <- insertDocs masterUserId masterCorpusId (map (toNode masterUserId masterCorpusId) hs )
   _ <- Doc.add masterCorpusId ids'
   -- TODO
   -- create a corpus with database name (CSV or PubMed)
@@ -368,15 +353,6 @@ instance HasText HyperdataDocument
                           , _hd_abstract h
                           ]
 
-instance HasText (Node HyperdataDocument)
-  where
-    hasText n = catMaybes [ _hd_title    h
-                          , _hd_abstract h
-                          ]
-      where
-        h = _node_hyperdata n
-
-
 
 instance ExtractNgramsT HyperdataDocument
   where
@@ -411,4 +387,12 @@ instance ExtractNgramsT HyperdataDocument
                              <> [(a', Map.singleton Authors     1) | a' <- authors    ]
                              <> [(t', Map.singleton NgramsTerms 1) | t' <- terms'     ]
 
+instance (ExtractNgramsT a, HasText a) => ExtractNgramsT (Node a)
+  where
+    extractNgramsT l (Node _ _ _ _ _ _ _ h) = extractNgramsT l h
+
+instance HasText a => HasText (Node a)
+  where
+    hasText (Node _ _ _ _ _ _ _ h) = hasText h
+
 

src/Gargantext/Database/Action/Flow/Types.hs

@@ -19,6 +19,7 @@ Portability : POSIX
 module Gargantext.Database.Action.Flow.Types
     where
 
+import Data.Aeson (ToJSON)
 import Gargantext.Core.Flow.Types
 import Gargantext.Core.Text
 import Gargantext.Core.Text.Terms
@@ -39,6 +40,11 @@ type FlowCorpus a = ( AddUniqId      a
                     , InsertDb       a
                     , ExtractNgramsT a
                     , HasText        a
-                    -- , ToNode         a
+                    , ToNode         a
+                    , ToJSON         a
                     )
 
+type FlowInsertDB a = ( AddUniqId a
+                      , UniqId    a
+                      , InsertDb  a
+                      )

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

@@ -36,7 +36,7 @@ import GHC.Generics (Generic)
 import Prelude (Enum, Bounded, minBound, maxBound)
 import Servant
 import qualified Opaleye as O
-import Opaleye (QueryRunnerColumnDefault, queryRunnerColumnDefault, PGInt4, PGTSVector, Nullable, fieldQueryRunnerColumn)
+import Opaleye (QueryRunnerColumnDefault, queryRunnerColumnDefault, PGInt4, PGText, PGTSVector, Nullable, fieldQueryRunnerColumn)
 import Test.QuickCheck (elements)
 import Gargantext.Prelude.Crypto.Hash (Hash)
 import Test.QuickCheck.Arbitrary
@@ -54,7 +54,7 @@ type UserId = Int
 type MasterUserId = UserId
 ------------------------------------------------------------------------
 -- | NodePoly indicates that Node has a Polymorphism Type
-type Node json   = NodePoly NodeId Hash NodeTypeId UserId (Maybe ParentId) NodeName UTCTime json
+type Node json   = NodePoly NodeId (Maybe Hash) NodeTypeId UserId (Maybe ParentId) NodeName UTCTime json
 
 -- | NodeSearch (queries)
 -- type NodeSearch json   = NodePolySearch NodeId NodeTypeId UserId (Maybe ParentId) NodeName UTCTime json (Maybe TSVector)
@@ -347,3 +347,8 @@ instance (QueryRunnerColumnDefault (Nullable O.PGTimestamptz) UTCTime)
   where
     queryRunnerColumnDefault = fieldQueryRunnerColumn
 
+instance QueryRunnerColumnDefault PGText (Maybe Hash)
+  where
+    queryRunnerColumnDefault = fieldQueryRunnerColumn
+
+

src/Gargantext/Database/Query/Table/Node/Document/Insert.hs

@@ -57,8 +57,8 @@ module Gargantext.Database.Query.Table.Node.Document.Insert
 import Control.Lens (set, view)
 import Control.Lens.Cons
 import Control.Lens.Prism
-import Data.Aeson (toJSON, encode{-, ToJSON-})
-import Data.Maybe (maybe)
+import Data.Aeson (toJSON, encode, ToJSON)
+import Data.Maybe (maybe, fromMaybe)
 import Data.Text (Text)
 -- import Data.ByteString (ByteString)
 import Data.Time.Segment (jour)
@@ -66,7 +66,7 @@ import Database.PostgreSQL.Simple (FromRow, Query, Only(..))
 import Database.PostgreSQL.Simple.FromRow (fromRow, field)
 -- import Database.PostgreSQL.Simple.ToRow (toRow, ToRow)
 import Database.PostgreSQL.Simple.SqlQQ
-import Database.PostgreSQL.Simple.ToField (toField, Action)
+import Database.PostgreSQL.Simple.ToField (toField, Action{-, ToField-})
 import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
 import GHC.Generics (Generic)
 import Gargantext.Database.Admin.Config (nodeTypeId)
@@ -123,7 +123,7 @@ instance InsertDb HyperdataContact
                       , (toField . toJSON) h
                       ]
 
-instance InsertDb (Node HyperdataDocument)
+instance ToJSON a => InsertDb (Node a)
   where
     insertDb' _u _p (Node _nid hashId t u p n d h) = [ toField hashId
                                                      , toField t
@@ -131,7 +131,7 @@ instance InsertDb (Node HyperdataDocument)
                                                      , toField p
                                                      , toField n
                                                      , toField d
-                                                     , toField h
+                                                     , (toField . toJSON) h
                                                      ]
 
 -- | Debug SQL function
@@ -217,9 +217,21 @@ secret :: Text
 secret = "Database secret to change"
 
 
-instance AddUniqId (Node HyperdataDocument)
+instance (AddUniqId a, ToJSON a) => AddUniqId (Node a)
   where
     addUniqId (Node nid _ t u p n d h) = Node nid hashId t u p n d h
+                              where
+                                hashId = Just $ "\\x" <> (hash $ DT.concat params)
+                                params = [ secret
+                                         , cs $ show $ nodeTypeId NodeDocument
+                                         , n
+                                         , cs $ show p
+                                         , cs $ encode h
+                                         ]
+    {-
+    addUniqId n@(Node nid _ t u p n d h)  =
+      case n of
+        Node HyperdataDocument -> Node nid hashId t u p n d h
                               where
                                 hashId = "\\x" <> (hash $ DT.concat params)
                                 params = [ secret
@@ -228,6 +240,8 @@ instance AddUniqId (Node HyperdataDocument)
                                          , cs $ show p
                                          , cs $ encode h
                                          ]
+       _ -> undefined
+-}
 
     ---------------------------------------------------------------------------
 -- * Uniqueness of document definition
@@ -255,3 +269,23 @@ maybeText :: Maybe Text -> Text
 maybeText = maybe (DT.pack "") identity
 
 ---------------------------------------------------------------------------
+class ToNode a
+  where
+    -- TODO Maybe NodeId
+    toNode :: UserId -> ParentId -> a -> Node a
+
+instance ToNode HyperdataDocument where
+  toNode u p h = Node 0 Nothing (nodeTypeId NodeDocument) u (Just p) n date h
+    where
+      n    = maybe "No Title" (DT.take 255) (_hd_title h)
+      date  = jour y m d
+      y = maybe 0 fromIntegral $ _hd_publication_year  h
+      m = fromMaybe 1 $ _hd_publication_month h
+      d = fromMaybe 1 $ _hd_publication_day   h
+
+-- TODO
+instance ToNode HyperdataContact where
+  toNode = undefined
+
+
+

src/Gargantext/Prelude.hs

@@ -11,7 +11,7 @@ Portability : POSIX
 
 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
 {-# OPTIONS_GHC -fno-warn-type-defaults  #-}
-
+{-# LANGUAGE TemplateHaskell #-}
 
 module Gargantext.Prelude
   ( module Gargantext.Prelude