Skip to content

haskell-gargantext
haskell-gargantext
Commit 458283b7 authored by Alexandre Delanoë's avatar Alexandre Delanoë
Browse files
Options

[FIX] TextFlow insertDB done

parent ee2b59e9
Hide whitespace changes
Inline Side-by-side
Showing with 98 additions and 60 deletions
bin/gargantext-server/Main.hs
View file @ 458283b7
......@@ -11,9 +11,10 @@ Script to start gargantext with different modes (Dev, Prod, Mock).
-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE Strict #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE Strict #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Main where
......
package.yaml
View file @ 458283b7
......@@ -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
View file @ 458283b7
......@@ -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
View file @ 458283b7
......@@ -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
View file @ 458283b7
......@@ -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
View file @ 458283b7
......@@ -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
View file @ 458283b7
......@@ -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
View file @ 458283b7
......@@ -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
View file @ 458283b7
......@@ -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)
......@@ -76,7 +76,7 @@ import Gargantext.Database.Prelude (Cmd, runPGSQuery{-, formatPGSQuery-})
import Gargantext.Database.Schema.Node (NodePoly(..))
import Gargantext.Prelude
import Gargantext.Prelude.Crypto.Hash (hash)
import qualified Data.Text as DT (pack, concat, take)
import qualified Data.Text as DT (pack, concat, take)
{-| To Print result query
import Data.ByteString.Internal (ByteString)
......@@ -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,17 +217,31 @@ 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 = "\\x" <> (hash $ DT.concat params)
params = [ secret
, cs $ show $ nodeTypeId NodeDocument
, n
, cs $ show p
, cs $ encode h
]
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
, cs $ show $ nodeTypeId NodeDocument
, n
, cs $ show p
, cs $ encode h
]
_ -> undefined
-}
---------------------------------------------------------------------------
-- * Uniqueness of document definition
......@@ -246,8 +260,8 @@ addUniqIdsContact hc = set (hc_uniqIdBdd) (Just shaBdd)
-- | TODO add more shaparameters
shaParametersContact :: [(HyperdataContact -> Text)]
shaParametersContact = [ \d -> maybeText $ view (hc_who . _Just . cw_firstName ) d
, \d -> maybeText $ view (hc_who . _Just . cw_lastName ) d
shaParametersContact = [ \d -> maybeText $ view (hc_who . _Just . cw_firstName ) d
, \d -> maybeText $ view (hc_who . _Just . cw_lastName ) d
, \d -> maybeText $ view (hc_where . _head . cw_touch . _Just . ct_mail) d
]
......@@ -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
View file @ 458283b7
......@@ -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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment