[DBFLOW] lenses to NodePoly + refacto.

src/Gargantext/Core/Types/Main.hs

@@ -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

@@ -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

@@ -47,7 +47,7 @@ nodeTypeId n =
 --  MapList    -> 8
 
 ----  Scores
-    NodeOccurrences -> 10
+--    NodeOccurrences -> 10
     NodeGraph       -> 9
     NodeDashboard   -> 5
     NodeChart       -> 51

src/Gargantext/Database/Facet.hs

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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