Skip to content

H
haskell-gargantext
Commit 65bc93a8 authored by Alexandre Delanoë's avatar Alexandre Delanoë
Browse files
Options

[ANNUAIRE] Contact type and mkAnnuaire function.

parent d10c458f
Hide whitespace changes
Inline Side-by-side
Showing with 174 additions and 67 deletions
package.yaml
View file @ 65bc93a8
......@@ -39,6 +39,7 @@ library:
- Gargantext.Database.Bashql
- Gargantext.Database.Node.Document.Insert
- Gargantext.Database.Node.Document.Add
- Gargantext.Database.Node.Contact
- Gargantext.Database.Types.Node
- Gargantext.Database.User
- Gargantext.Database.Cooc
......
src/Gargantext/Database/Flow.hs
View file @ 65bc93a8
......@@ -8,14 +8,6 @@ Stability : experimental
Portability : POSIX
Map (NgramsId, NodeId) -> insert
data NgramsType = Sources | Authors | Terms
nodes_ngrams : column type, column list
documents
sources
authors
-}
{-# LANGUAGE DeriveGeneric #-}
......@@ -36,7 +28,7 @@ import qualified Data.Map as DM
import Gargantext.Core.Types (NodePoly(..), ListType(..), listTypeId)
import Gargantext.Database.Bashql (runCmd') -- , del)
import Gargantext.Database.Ngrams (insertNgrams, Ngrams(..), NgramsT(..), NgramsIndexed(..), indexNgramsT, ngramsTypeId, NgramsType(..), text2ngrams)
import Gargantext.Database.Node (getRoot, mkRoot, mkCorpus, Cmd(..), mkList, mkGraph, mkDashboard)
import Gargantext.Database.Node (getRoot, mkRoot, mkCorpus, Cmd(..), mkList, mkGraph, mkDashboard, mkAnnuaire)
import Gargantext.Database.Node.Document.Add (add)
import Gargantext.Database.Node.Document.Insert (insertDocuments, ReturnId(..), addUniqIds)
import Gargantext.Database.NodeNgram (NodeNgramPoly(..), insertNodeNgrams)
......@@ -56,12 +48,12 @@ flowDatabase :: FileFormat -> FilePath -> CorpusName -> IO Int
flowDatabase ff fp cName = do
-- Corus Flow
(masterUserId, _, corpusId) <- subFlow userMaster corpusMasterName
(masterUserId, _, corpusId) <- subFlowCorpus userMaster corpusMasterName
-- Documents Flow
hyperdataDocuments <- map addUniqIds <$> parseDocs ff fp
--printDebug "hyperdataDocuments" hyperdataDocuments
printDebug "hyperdataDocuments" hyperdataDocuments
ids <- runCmd' $ insertDocuments masterUserId corpusId hyperdataDocuments
--printDebug "Docs IDs : " (ids)
......@@ -70,14 +62,14 @@ flowDatabase ff fp cName = do
-- Ngrams Flow
-- todo: flow for new documents only
-- let tids = toInserted ids
--printDebug "toInserted ids" (length tids, tids)
let tids = toInserted ids
printDebug "toInserted ids" (length tids, tids)
-- let tihs = toInsert hyperdataDocuments
--printDebug "toInsert hyperdataDocuments" (length tihs, tihs)
let tihs = toInsert hyperdataDocuments
printDebug "toInsert hyperdataDocuments" (length tihs, tihs)
let documentsWithId = mergeData (toInserted ids) (toInsert hyperdataDocuments)
-- printDebug "documentsWithId" documentsWithId
printDebug "documentsWithId" documentsWithId
-- docsWithNgrams <- documentIdWithNgrams documentsWithId extractNgramsT
let docsWithNgrams = documentIdWithNgrams extractNgramsT documentsWithId
......@@ -94,7 +86,7 @@ flowDatabase ff fp cName = do
listId2 <- runCmd' $ listFlow masterUserId corpusId indexedNgrams
printDebug "list id : " listId2
(userId, _, corpusId2) <- subFlow userArbitrary cName
(userId, rootUserId, corpusId2) <- subFlowCorpus userArbitrary cName
userListId <- runCmd' $ listFlowUser userId corpusId2
printDebug "UserList : " userListId
......@@ -103,15 +95,18 @@ flowDatabase ff fp cName = do
printDebug "Inserted : " (length inserted)
_ <- runCmd' $ mkDashboard corpusId2 userId
_ <- runCmd' $ mkGraph corpusId2 userId
_ <- runCmd' $ mkGraph corpusId2 userId
-- Annuaire Flow
annuaireId <- runCmd' $ mkAnnuaire rootUserId userId
pure corpusId2
-- runCmd' $ del [corpusId2, corpusId]
type CorpusName = Text
subFlow :: Username -> CorpusName -> IO (UserId, RootId, CorpusId)
subFlow username cName = do
subFlowCorpus :: Username -> CorpusName -> IO (UserId, RootId, CorpusId)
subFlowCorpus username cName = do
maybeUserId <- runCmd' (getUser username)
let userId = case maybeUserId of
......
src/Gargantext/Database/Ngrams.hs
View file @ 65bc93a8
......@@ -234,22 +234,24 @@ getNgramsTableData conn nodeT ngrmT (NgramsTableParam ul uc) (NgramsTableParam m
querySelectTableNgrams :: DPS.Query
querySelectTableNgrams = [sql|
WITH tableUser AS (select ngs.terms, ngs.n, nn1.ngrams_type,nn2.weight FROM ngrams ngs
JOIN nodes_ngrams nn1 ON nn1.ngram_id = ngs.id
JOIN nodes_ngrams nn2 ON nn2.ngram_id = ngs.id
JOIN nodes n ON n.id = nn2.node_id
WHERE nn1.node_id = ? -- User listId
AND n.parent_id = ? -- User CorpusId or AnnuaireId
AND n.typename = ? -- both type of childs (Documents or Contacts)
AND nn2.ngrams_type = ? -- both type of ngrams (Authors or Terms?)
), tableMaster AS (select ngs.terms, ngs.n, nn1.ngrams_type,nn2.weight FROM ngrams ngs
JOIN nodes_ngrams nn1 ON nn1.ngram_id = ngs.id
JOIN nodes_ngrams nn2 ON nn2.ngram_id = ngs.id
JOIN nodes n ON n.id = nn2.node_id
WHERE nn1.node_id = ? -- Master listId
AND n.parent_id = ? -- Master CorpusId or AnnuaireId
AND n.typename = ? -- both type of childs (Documents or Contacts)
AND nn2.ngrams_type = ? -- both type of ngrams (Authors or Terms?)
WITH tableUser AS (
SELECT ngs.terms, ngs.n, nn1.ngrams_type,nn2.weight FROM ngrams ngs
JOIN nodes_ngrams nn1 ON nn1.ngram_id = ngs.id
JOIN nodes_ngrams nn2 ON nn2.ngram_id = ngs.id
JOIN nodes n ON n.id = nn2.node_id
WHERE nn1.node_id = ? -- User listId
AND n.parent_id = ? -- User CorpusId or AnnuaireId
AND n.typename = ? -- both type of childs (Documents or Contacts)
AND nn2.ngrams_type = ? -- both type of ngrams (Authors or Terms?)
), tableMaster AS (
SELECT ngs.terms, ngs.n, nn1.ngrams_type,nn2.weight FROM ngrams ngs
JOIN nodes_ngrams nn1 ON nn1.ngram_id = ngs.id
JOIN nodes_ngrams nn2 ON nn2.ngram_id = ngs.id
JOIN nodes n ON n.id = nn2.node_id
WHERE nn1.node_id = ? -- Master listId
AND n.parent_id = ? -- Master CorpusId or AnnuaireId
AND n.typename = ? -- both type of childs (Documents or Contacts)
AND nn2.ngrams_type = ? -- both type of ngrams (Authors or Terms?)
)
SELECT COALESCE(tu.terms,tm.terms) AS terms
......
src/Gargantext/Database/Node.hs
View file @ 65bc93a8
......@@ -40,6 +40,7 @@ import Prelude hiding (null, id, map, sum)
import Gargantext.Core (Lang(..))
import Gargantext.Core.Types
import Gargantext.Database.Utils (fromField')
import Gargantext.Database.Types.Node (NodeType, defaultCorpus, Hyperdata)
import Gargantext.Database.Queries
import Gargantext.Database.Config (nodeTypeId)
......@@ -139,16 +140,6 @@ instance QueryRunnerColumnDefault PGJsonb HyperdataAnnuaire where
queryRunnerColumnDefault = fieldQueryRunnerColumn
------------------------------------------------------------------------
fromField' :: (Typeable b, FromJSON b) => Field -> Maybe DB.ByteString -> Conversion b
fromField' field mb = do
v <- fromField field mb
valueToHyperdata v
where
valueToHyperdata v = case fromJSON v of
Success a -> pure a
Error _err -> returnError ConversionFailed field "cannot parse hyperdata"
$(makeAdaptorAndInstance "pNode" ''NodePoly)
$(makeLensesWith abbreviatedFields ''NodePoly)
......@@ -372,14 +363,7 @@ nodeAnnuaireW maybeName maybeAnnuaire pId = node NodeAnnuaire name annuaire (Jus
name = maybe "Annuaire" identity maybeName
annuaire = maybe defaultAnnuaire identity maybeAnnuaire
--------------------------
defaultContact :: HyperdataContact
defaultContact = HyperdataContact (Just "Name") (Just "email@here")
nodeContactW :: Maybe Name -> Maybe HyperdataContact -> AnnuaireId -> UserId -> NodeWrite'
nodeContactW maybeName maybeContact aId = node NodeContact name contact (Just aId)
where
name = maybe "Contact" identity maybeName
contact = maybe defaultContact identity maybeContact
------------------------------------------------------------------------
arbitraryList :: HyperdataList
arbitraryList = HyperdataList (Just "Preferences")
......@@ -566,7 +550,8 @@ mkGraph p u = insertNodesR' [nodeGraphW Nothing Nothing p u]
mkDashboard :: ParentId -> UserId -> Cmd [Int]
mkDashboard p u = insertNodesR' [nodeDashboardW Nothing Nothing p u]
mkAnnuaire :: ParentId -> UserId -> Cmd [Int]
mkAnnuaire p u = insertNodesR' [nodeAnnuaireW Nothing Nothing p u]
-- | Default CorpusId Master and ListId Master
src/Gargantext/Database/Node/Contact.hs 0 → 100644
View file @ 65bc93a8
{-|
Module : Gargantext.Database.Node.Contact
Description : Update Node in Database (Postgres)
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Database.Node.Contact (NodeContact,HyperdataContact, ContactWho, ContactWhere, ContactTouch)
where
import GHC.Generics (Generic)
import Data.Aeson.TH (deriveJSON)
import Data.Text (Text)
import qualified Data.Text as DT
import Control.Lens (makeLenses)
import Database.PostgreSQL.Simple
import Opaleye (QueryRunnerColumnDefault
, queryRunnerColumnDefault, PGJsonb, fieldQueryRunnerColumn)
import Gargantext.Database.Utils (fromField')
import Gargantext.Core.Utils.Prefix (unPrefix)
import Gargantext.Database.Node (NodeWrite', AnnuaireId, UserId, Name, node)
import Gargantext.Prelude
import Gargantext.Database.Types.Node (Node,Hyperdata,NodeType(..))
import Data.Aeson (Result(Error,Success), fromJSON, FromJSON, ToJSON)
import Database.PostgreSQL.Simple.FromField ( Conversion
, ResultError(ConversionFailed)
, FromField
, fromField
, returnError
)
------------------------------------------------------------------------
type NodeContact = Node HyperdataContact
data HyperdataContact =
HyperdataContact { _hc_who :: Maybe ContactWho
, _hc_where :: Maybe [ContactWhere]
, _hc_lastValidation :: Maybe Text
} deriving (Eq, Show, Generic)
arbitraryHyperdataContact :: HyperdataContact
arbitraryHyperdataContact = HyperdataContact Nothing Nothing Nothing
data ContactWho =
ContactWho { _cw_id :: Maybe Int
, _cw_firstName :: Maybe Text
, _cw_lastName :: Maybe Text
, _cw_keywords :: Maybe [Text]
, _cw_freetags :: Maybe [Text]
} deriving (Eq, Show, Generic)
data ContactWhere =
ContactWhere { _cw_organization :: Maybe [Text]
, _cw_labTeamDepts :: Maybe [Text]
, _cw_role :: Maybe Text
, _cw_office :: Maybe Text
, _cw_country :: Maybe Text
, _cw_city :: Maybe Text
, _cw_touch :: Maybe ContactTouch
} deriving (Eq, Show, Generic)
data ContactTouch =
ContactTouch { _ct_mail :: Maybe Text
, _ct_phone :: Maybe Text
, _ct_url :: Maybe Text
} deriving (Eq, Show, Generic)
nodeContactW :: Maybe Name -> Maybe HyperdataContact
-> AnnuaireId -> UserId -> NodeWrite'
nodeContactW maybeName maybeContact aId =
node NodeContact name contact (Just aId)
where
name = maybe "Contact" identity maybeName
contact = maybe arbitraryHyperdataContact identity maybeContact
instance Hyperdata HyperdataContact
instance FromField HyperdataContact where
fromField = fromField'
instance QueryRunnerColumnDefault PGJsonb HyperdataContact where
queryRunnerColumnDefault = fieldQueryRunnerColumn
{-
makeLenses ''ContactWho
makeLenses ''ContactWhere
makeLenses ''ContactTouch
makeLenses ''HyperdataContact
-}
$(deriveJSON (unPrefix "_cw_") ''ContactWho)
$(deriveJSON (unPrefix "_cw_") ''ContactWhere)
$(deriveJSON (unPrefix "_ct_") ''ContactTouch)
$(deriveJSON (unPrefix "_hc_") ''HyperdataContact)
src/Gargantext/Database/Types/Node.hs
View file @ 65bc93a8
......@@ -54,7 +54,6 @@ import Test.QuickCheck (elements)
import Gargantext.Prelude
import Gargantext.Core.Utils.Prefix (unPrefix)
------------------------------------------------------------------------
type UTCTime' = UTCTime
......@@ -260,13 +259,6 @@ hyperdataAnnuaire = HyperdataAnnuaire (Just "Annuaire Title") (Just "Annuaire De
instance Arbitrary HyperdataAnnuaire where
arbitrary = pure hyperdataAnnuaire -- TODO
------------------------------------------------------------------------
data HyperdataContact = HyperdataContact { hyperdataContact_name :: Maybe Text
, hyperdataContact_mail :: Maybe Text
} deriving (Show, Generic)
$(deriveJSON (unPrefix "hyperdataContact_") ''HyperdataContact)
instance Hyperdata HyperdataContact
------------------------------------------------------------------------
newtype HyperdataAny = HyperdataAny Object
deriving (Show, Generic, ToJSON, FromJSON)
......@@ -352,7 +344,6 @@ type NodeCorpusV3 = Node HyperdataCorpus
type NodeDocument = Node HyperdataDocument
type NodeAnnuaire = Node HyperdataAnnuaire
type NodeContact = Node HyperdataContact
---- | Then a Node can be either a Graph or a Phylo or a Notebook
type NodeList = Node HyperdataList
......
src/Gargantext/Database/Utils.hs
View file @ 65bc93a8
......@@ -19,15 +19,26 @@ module Gargantext.Database.Utils where
import qualified Database.PostgreSQL.Simple as PGS
import Data.Aeson (Result(Error,Success), fromJSON, FromJSON)
import Data.Typeable (Typeable)
import Data.Monoid ((<>))
import Data.Either.Extra (Either(Left, Right))
import Gargantext.Prelude
import Data.Text (unpack, pack)
import Text.Read (read)
import Database.PostgreSQL.Simple.Internal (Field)
import qualified Data.ByteString as DB
import Database.PostgreSQL.Simple.FromField ( Conversion
, ResultError(ConversionFailed)
, FromField
, fromField
, returnError
)
import Data.Ini (readIniFile, lookupValue)
import Data.Text (unpack, pack)
import Data.Word (Word16)
import System.IO (FilePath)
import Database.PostgreSQL.Simple (Connection, connect)
import Gargantext.Prelude
import System.IO (FilePath)
import Text.Read (read)
-- Utilities
import Opaleye (Query, Unpackspec, showSqlForPostgres)
......@@ -60,4 +71,14 @@ connectGargandb fp = databaseParameters fp >>= \params -> connect params
printSql :: Default Unpackspec a a => Query a -> IO ()
printSql = putStrLn . maybe "Empty query" identity . showSqlForPostgres
fromField' :: (Typeable b, FromJSON b) => Field -> Maybe DB.ByteString -> Conversion b
fromField' field mb = do
v <- fromField field mb
valueToHyperdata v
where
valueToHyperdata v = case fromJSON v of
Success a -> pure a
Error _err -> returnError ConversionFailed field "cannot parse hyperdata"
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