Skip to content

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

[DBFLOW] lenses to NodePoly + refacto.

parent ed24e95d
Hide whitespace changes
Inline Side-by-side
Showing with 108 additions and 69 deletions
src/Gargantext/Core/Types/Main.hs
View file @ ae56679c
......@@ -87,9 +87,6 @@ data Lists = StopList | MainList | MapList | GroupList
-- | Community Manager Use Case
type Annuaire = NodeCorpus
-- | Favorites Node enable Node categorization
type Favorites = Node HyperdataFavorites
-- | Favorites Node enable Swap Node with some synonyms for clarity
type NodeSwap = Node HyperdataResource
......@@ -114,12 +111,6 @@ type TfidfGlobal = Tficf
type TirankLocal = Tficf
type TirankGlobal = Tficf
--
---- | Then a Node can be either a Graph or a Phylo or a Notebook
type Graph = Node HyperdataGraph
type Phylo = Node HyperdataPhylo
type Notebook = Node HyperdataNotebook
-- Temporary types to be removed
type ErrorMessage = Text
......
src/Gargantext/Database/Bashql.hs
View file @ ae56679c
......@@ -109,7 +109,7 @@ get pwd = Cmd . ReaderT $ \conn -> runQuery conn $ selectNodesWithParentID (last
-- | Home, need to filter with UserId
home :: Cmd PWD
home = map node_id <$> Cmd (ReaderT (getNodesWithParentId 0 Nothing))
home = map _node_id <$> Cmd (ReaderT (getNodesWithParentId 0 Nothing))
-- | ls == get Children
ls :: PWD -> Cmd [Node Value]
......@@ -118,14 +118,14 @@ ls = get
tree :: PWD -> Cmd [Node Value]
tree p = do
ns <- get p
children <- mapM (\n -> get [node_id n]) ns
children <- mapM (\n -> get [_node_id n]) ns
pure $ ns <> concat children
-- | TODO
post :: PWD -> [NodeWrite'] -> Cmd Int64
post [] _ = pure 0
post _ [] = pure 0
post pth ns = Cmd . ReaderT $ insertNode (Just $ last pth) ns
post pth ns = Cmd . ReaderT $ insertNodesWithParent (Just $ last pth) ns
--postR :: PWD -> [NodeWrite'] -> Cmd [Int]
--postR [] _ _ = pure [0]
......
src/Gargantext/Database/Config.hs
View file @ ae56679c
......@@ -47,7 +47,7 @@ nodeTypeId n =
-- MapList -> 8
---- Scores
NodeOccurrences -> 10
-- NodeOccurrences -> 10
NodeGraph -> 9
NodeDashboard -> 5
NodeChart -> 51
......
src/Gargantext/Database/Facet.hs
View file @ ae56679c
......@@ -220,8 +220,8 @@ leftJoin3''' = leftJoin3 queryNodeNodeTable queryNodeTable queryNodeTable cond12
selectDocFacet' :: NodeType -> ParentId -> Maybe NodeType -> Query FacetDocRead
selectDocFacet' _ pId _ = proc () -> do
(n1,(nn,n2)) <- leftJoin3''' -< ()
restrict -< (.&&) (node_parentId n1 .== (toNullable $ pgInt4 pId))
(node_typename n1 .== (pgInt4 $ nodeTypeId NodeDocument))
restrict -< (.&&) (_node_parentId n1 .== (toNullable $ pgInt4 pId))
(_node_typename n1 .== (pgInt4 $ nodeTypeId NodeDocument))
-- restrict -< (.||) (node_typename n2 .== (toNullable $ pgInt4 $ nodeTypeId Favorites))
-- (isNull $ node_typename n2)
......@@ -231,6 +231,6 @@ selectDocFacet' _ pId _ = proc () -> do
let isFav = ifThenElse (isNull $ nodeNode_score nn) (pgBool False) (pgBool True)
returnA -< FacetDoc (node_id n1) (node_date n1) (node_hyperdata n1) (isFav) (pgInt4 1)
returnA -< FacetDoc (_node_id n1) (_node_date n1) (_node_hyperdata n1) (isFav) (pgInt4 1)
src/Gargantext/Database/Flow.hs
View file @ ae56679c
......@@ -48,7 +48,7 @@ flow = do
Nothing -> panic "Error: User does not exist (yet)" -- mk NodeUser gargantua_id "Node Gargantua"
Just user -> userLight_id user
root <- map node_id <$> runCmd' (getRoot masterUserId)
root <- map _node_id <$> runCmd' (getRoot masterUserId)
root' <- case root of
[] -> runCmd' (mkRoot masterUserId)
......
src/Gargantext/Database/Node.hs
View file @ ae56679c
......@@ -25,6 +25,7 @@ module Gargantext.Database.Node where
import Data.Text (pack)
import GHC.Int (Int64)
import Control.Lens (set)
import Data.Maybe
import Data.Time (UTCTime)
import Database.PostgreSQL.Simple.FromField ( Conversion
......@@ -86,6 +87,7 @@ mkCmd = Cmd . ReaderT
------------------------------------------------------------------------
type CorpusId = Int
type AnnuaireId = Int
type UserId = NodeId
type TypeId = Int
------------------------------------------------------------------------
......@@ -129,13 +131,13 @@ $(makeLensesWith abbreviatedFields ''NodePoly)
nodeTable :: Table NodeWrite NodeRead
nodeTable = Table "nodes" (pNode Node { node_id = optional "id"
, node_typename = required "typename"
, node_userId = required "user_id"
, node_parentId = required "parent_id"
, node_name = required "name"
, node_date = optional "date"
, node_hyperdata = required "hyperdata"
nodeTable = Table "nodes" (pNode Node { _node_id = optional "id"
, _node_typename = required "typename"
, _node_userId = required "user_id"
, _node_parentId = required "parent_id"
, _node_name = required "name"
, _node_date = optional "date"
, _node_hyperdata = required "hyperdata"
-- , node_titleAbstract = optional "title_abstract"
}
)
......@@ -175,7 +177,7 @@ queryNodeTable = queryTable nodeTable
selectNode :: Column PGInt4 -> Query NodeRead
selectNode id = proc () -> do
row <- queryNodeTable -< ()
restrict -< node_id row .== id
restrict -< _node_id row .== id
returnA -< row
runGetNodes :: Query NodeRead -> Cmd [Node Value]
......@@ -185,8 +187,8 @@ runGetNodes q = mkCmd $ \conn -> runQuery conn q
selectRootUser :: UserId -> Query NodeRead
selectRootUser userId = proc () -> do
row <- queryNodeTable -< ()
restrict -< node_userId row .== (pgInt4 userId)
restrict -< node_typename row .== (pgInt4 $ nodeTypeId NodeUser)
restrict -< _node_userId row .== (pgInt4 userId)
restrict -< _node_typename row .== (pgInt4 $ nodeTypeId NodeUser)
returnA -< row
getRoot :: UserId -> Cmd [Node HyperdataUser]
......@@ -199,7 +201,7 @@ selectNodesWith :: ParentId -> Maybe NodeType
-> Maybe Offset -> Maybe Limit -> Query NodeRead
selectNodesWith parentId maybeNodeType maybeOffset maybeLimit =
--offset' maybeOffset $ limit' maybeLimit $ orderBy (asc (hyperdataDocument_Publication_date . node_hyperdata)) $ selectNodesWith' parentId typeId
limit' maybeLimit $ offset' maybeOffset $ orderBy (asc node_id) $ selectNodesWith' parentId maybeNodeType
limit' maybeLimit $ offset' maybeOffset $ orderBy (asc _node_id) $ selectNodesWith' parentId maybeNodeType
selectNodesWith' :: ParentId -> Maybe NodeType -> Query NodeRead
selectNodesWith' parentId maybeNodeType = proc () -> do
......@@ -290,8 +292,9 @@ getNodesWithType conn type_id = do
------------------------------------------------------------------------
-- WIP
-- TODO Classe HasDefault where
-- default NodeType = Hyperdata
------------------------------------------------------------------------
type NodeWrite' = NodePoly (Maybe Int) Int Int (Maybe ParentId) Text (Maybe UTCTime) ByteString
------------------------------------------------------------------------
defaultUser :: HyperdataUser
......@@ -320,7 +323,7 @@ nodeCorpusW maybeName maybeCorpus pId = node NodeCorpus name (Hyperdata corpus)
where
name = maybe "Corpus" identity maybeName
corpus = maybe defaultCorpus identity maybeCorpus
------------------------------------------------------------------------
--------------------------
defaultDocument :: HyperdataDocument
defaultDocument = hyperdataDocument
......@@ -330,11 +333,24 @@ nodeDocumentW maybeName maybeDocument cId = node NodeDocument name (Hyperdata do
name = maybe "Document" identity maybeName
doc = maybe defaultDocument identity maybeDocument
------------------------------------------------------------------------
--defaultAnnuaire :: HyperdataAnnuaire
--defaultAnnuaire = HyperdataAnnuaire
--nodeAnnuaireW
--nodeContactW
defaultAnnuaire :: HyperdataAnnuaire
defaultAnnuaire = HyperdataAnnuaire (Just "Title") (Just "Description")
nodeAnnuaireW :: Maybe Name -> Maybe HyperdataAnnuaire -> ParentId -> UserId -> NodeWrite'
nodeAnnuaireW maybeName maybeAnnuaire pId = node NodeAnnuaire name (Hyperdata annuaire) (Just pId)
where
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 (Hyperdata contact) (Just aId)
where
name = maybe "Contact" identity maybeName
contact = maybe defaultContact identity maybeContact
------------------------------------------------------------------------
------------------------------------------------------------------------
node :: ToJSON a => NodeType -> Name -> Hyperdata a -> Maybe ParentId -> UserId -> NodeWrite'
node nodeType name hyperData parentId userId = Node Nothing typeId userId parentId name Nothing byteData
......@@ -342,7 +358,7 @@ node nodeType name hyperData parentId userId = Node Nothing typeId userId parent
typeId = nodeTypeId nodeType
byteData = DB.pack $ DBL.unpack $ encode $ unHyperdata hyperData
------------------------------------------------------------------------
node2write :: (Functor maybe1, Functor maybe2, Functor maybe3) =>
maybe1 Int -> NodePoly (maybe2 Int) Int Int parentId Text (maybe3 UTCTime) ByteString
-> (maybe2 (Column PGInt4), Column PGInt4, Column PGInt4,
......@@ -356,12 +372,32 @@ node2write pid (Node id tn ud _ nm dt hp) = ((pgInt4 <$> id)
,(pgUTCTime <$> dt)
,(pgStrictJSONB hp)
)
node2row :: (Functor maybe1, Functor maybe2, Functor maybe3) =>
NodePoly (maybe2 Int) Int Int (maybe1 Int)
Text (maybe3 UTCTime) ByteString
-> (maybe2 (Column PGInt4), Column PGInt4, Column PGInt4, maybe1 (Column PGInt4)
, Column PGText, maybe3 (Column PGTimestamptz), Column PGJsonb)
node2row (Node id tn ud pid nm dt hp) = ((pgInt4 <$> id)
,(pgInt4 tn)
,(pgInt4 ud)
,(pgInt4 <$> pid)
,(pgStrictText nm)
,(pgUTCTime <$> dt)
,(pgStrictJSONB hp)
)
------------------------------------------------------------------------
insertNode :: Maybe ParentId -> [NodeWrite'] -> Connection -> IO Int64
insertNode pid ns conn = runInsertMany conn nodeTable' $ map (node2write pid) ns
insertNodes :: [NodeWrite'] -> Connection -> IO Int64
insertNodes ns conn = runInsertMany conn nodeTable' (map node2row ns)
insertNodesR :: [NodeWrite'] -> Connection -> IO [Int]
insertNodesR ns conn = runInsertManyReturning conn nodeTable' (map node2row ns) (\(i,_,_,_,_,_,_) -> i)
-------------------------
insertNodesWithParent :: Maybe ParentId -> [NodeWrite'] -> Connection -> IO Int64
insertNodesWithParent pid ns conn = insertNodes (map (set node_parentId pid) ns) conn
insertNodeR :: Maybe ParentId -> [NodeWrite'] -> Connection -> IO [Int]
insertNodeR pid ns conn = runInsertManyReturning conn nodeTable' (map (node2write pid) ns) (\(i,_,_,_,_,_,_) -> i)
insertNodesWithParentR :: Maybe ParentId -> [NodeWrite'] -> Connection -> IO [Int]
insertNodesWithParentR pid ns conn = insertNodesR (map (set node_parentId pid) ns) conn
------------------------------------------------------------------------
-- TODO Hierachy of Nodes
-- post and get same types Node' and update if changes
......@@ -448,7 +484,7 @@ mk :: Connection -> NodeType -> Maybe ParentId -> Text -> IO [Int]
mk c nt pId name = mk' c nt userId pId name
mk' :: Connection -> NodeType -> UserId -> Maybe ParentId -> Text -> IO [Int]
mk' c nt uId pId name = map fromIntegral <$> insertNodeR pId [node nt name hd pId uId] c
mk' c nt uId pId name = map fromIntegral <$> insertNodesWithParentR pId [node nt name hd pId uId] c
where
hd = Hyperdata (HyperdataUser (Just $ (pack . show) EN))
......
src/Gargantext/Database/Types/Node.hs
View file @ ae56679c
......@@ -97,8 +97,6 @@ data HyperdataDocumentV3 = HyperdataDocumentV3 { hyperdataDocumentV3_publication
, hyperdataDocumentV3_title :: Maybe Text
} deriving (Show, Generic)
$(deriveJSON (unPrefix "hyperdataDocumentV3_") ''HyperdataDocumentV3)
------------------------------------------------------------------------
data HyperdataDocument = HyperdataDocument { _hyperdataDocument_bdd :: Maybe Text
......@@ -194,26 +192,36 @@ instance Arbitrary Resource where
data Hyperdata a = Hyperdata { unHyperdata :: a}
$(deriveJSON (unPrefix "") ''Hyperdata)
data HyperdataCorpus = HyperdataCorpus { hyperdataCorpus_title :: Maybe Text
, hyperdataCorpus_descr :: Maybe Text
, hyperdataCorpus_query :: Maybe Text
, hyperdataCorpus_authors :: Maybe Text
, hyperdataCorpus_resources :: Maybe [Resource]
} deriving (Show, Generic)
$(deriveJSON (unPrefix "hyperdataCorpus_") ''HyperdataCorpus)
data HyperdataUser = HyperdataUser { hyperdataUser_language :: Maybe Text
} deriving (Show, Generic)
$(deriveJSON (unPrefix "hyperdataUser_") ''HyperdataUser)
-- Preferences ?
data HyperdataFolder = HyperdataFolder { hyperdataFolder_descr :: Maybe Text
} deriving (Show, Generic)
$(deriveJSON (unPrefix "hyperdataFolder_") ''HyperdataFolder)
data HyperdataCorpus = HyperdataCorpus { hyperdataCorpus_title :: Maybe Text
, hyperdataCorpus_descr :: Maybe Text
, hyperdataCorpus_query :: Maybe Text
, hyperdataCorpus_authors :: Maybe Text
, hyperdataCorpus_resources :: Maybe [Resource]
} deriving (Show, Generic)
$(deriveJSON (unPrefix "hyperdataCorpus_") ''HyperdataCorpus)
------------------------------------------------------------------------
data HyperdataAnnuaire = HyperdataAnnuaire { hyperdataAnnuaire_title :: Maybe Text
, hyperdataAnnuaire_descr :: Maybe Text
} deriving (Show, Generic)
$(deriveJSON (unPrefix "hyperdataAnnuaire_") ''HyperdataAnnuaire)
------------------------------------------------------------------------
data HyperdataContact = HyperdataContact { hyperdataContact_name :: Maybe Text
, hyperdataContact_mail :: Maybe Text
} deriving (Show, Generic)
$(deriveJSON (unPrefix "hyperdataContact_") ''HyperdataContact)
------------------------------------------------------------------------
data HyperdataList = HyperdataList { hyperdataList_preferences :: Maybe Text
} deriving (Show, Generic)
$(deriveJSON (unPrefix "hyperdataList_") ''HyperdataList)
......@@ -223,10 +231,6 @@ data HyperdataScore = HyperdataScore { hyperdataScore_preferences :: Maybe Tex
$(deriveJSON (unPrefix "hyperdataScore_") ''HyperdataScore)
data HyperdataFavorites = HyperdataFavorites { hyperdataFavorites_preferences :: Maybe Text
} deriving (Show, Generic)
$(deriveJSON (unPrefix "hyperdataFavorites_") ''HyperdataFavorites)
data HyperdataResource = HyperdataResource { hyperdataResource_preferences :: Maybe Text
} deriving (Show, Generic)
$(deriveJSON (unPrefix "hyperdataResource_") ''HyperdataResource)
......@@ -267,16 +271,25 @@ type NodeName = Text
-- | Then a Node can be either a Folder or a Corpus or a Document
type NodeUser = Node HyperdataUser
type NodeFolder = Node HyperdataFolder
type NodeCorpus = Node HyperdataCorpus
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 NodeGraph = Node HyperdataGraph
type NodePhylo = Node HyperdataPhylo
type NodeNotebook = Node HyperdataNotebook
------------------------------------------------------------------------
data NodeType = NodeUser
| NodeFolder
| NodeCorpus | NodeCorpusV3 | NodeDocument
| NodeAnnuaire | NodeContact
| NodeOccurrences
-- | NodeOccurrences
| NodeGraph
| NodeDashboard | NodeChart
-- | Classification
......@@ -298,18 +311,17 @@ instance ToParamSchema NodeType
instance ToSchema NodeType
------------------------------------------------------------------------
data NodePoly id typename userId parentId name date hyperdata = Node { node_id :: id
, node_typename :: typename
, node_userId :: userId
-- , nodeHashId :: hashId
, node_parentId :: parentId
, node_name :: name
, node_date :: date
, node_hyperdata :: hyperdata
-- , node_titleAbstract :: titleAbstract
data NodePoly id typename userId parentId name date hyperdata = Node { _node_id :: id
, _node_typename :: typename
, _node_userId :: userId
-- , nodeUniqId :: hashId
, _node_parentId :: parentId
, _node_name :: name
, _node_date :: date
, _node_hyperdata :: hyperdata
} deriving (Show, Generic)
$(deriveJSON (unPrefix "node_") ''NodePoly)
$(deriveJSON (unPrefix "_node_") ''NodePoly)
$(makeLenses ''NodePoly)
......
src/Gargantext/TextFlow.hs
View file @ ae56679c
......@@ -85,7 +85,7 @@ textFlow termType workType = do
FullText path -> splitBy (Sentences 5) <$> readFile path
CSV path -> readCsvOn [csv_title, csv_abstract] path
Contexts ctxt -> pure ctxt
DB con corpusId -> catMaybes <$> map (\n -> hyperdataDocumentV3_title (node_hyperdata n) <> hyperdataDocumentV3_abstract (node_hyperdata n))<$> getDocumentsV3WithParentId con corpusId
DB con corpusId -> catMaybes <$> map (\n -> hyperdataDocumentV3_title (_node_hyperdata n) <> hyperdataDocumentV3_abstract (_node_hyperdata n))<$> getDocumentsV3WithParentId con corpusId
_ -> undefined -- TODO Query not supported
textFlow' termType contexts
......
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