[FIX] Missing files

src/Gargantext/Core/Flow/Ngrams.hs

+{-|
+Module      : Gargantext.Core.Flow.Ngrams
+Description : Core Flow main fun for Ngrams
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+
+-}
+
+{-# LANGUAGE ConstraintKinds   #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE RankNTypes        #-}
+{-# LANGUAGE ConstrainedClassMethods #-}
+
+module Gargantext.Core.Flow.Ngrams where
+
+-- import Gargantext.Text.Terms.WithList (filterWith)
+
+
+

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

+{-|
+Module      : Gargantext.Database.Types.Errors
+Description : Main requests of Node to the database
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+-}
+
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+{-# OPTIONS_GHC -fno-warn-orphans        #-}
+
+{-# LANGUAGE Arrows                 #-}
+{-# LANGUAGE DeriveGeneric          #-}
+{-# LANGUAGE ConstraintKinds        #-}
+{-# LANGUAGE FlexibleContexts       #-}
+{-# LANGUAGE FlexibleInstances      #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE OverloadedStrings      #-}
+{-# LANGUAGE MultiParamTypeClasses  #-}
+{-# LANGUAGE NoImplicitPrelude      #-}
+{-# LANGUAGE RankNTypes             #-}
+{-# LANGUAGE TemplateHaskell        #-}
+{-# LANGUAGE TypeFamilies           #-}
+
+module Gargantext.Database.Admin.Types.Errors where
+
+import Control.Lens (Prism', (#), (^?))
+import Control.Monad.Error.Class (MonadError(..))
+import Gargantext.Prelude hiding (sum, head)
+import Prelude hiding (null, id, map, sum)
+
+------------------------------------------------------------------------
+data NodeError = NoListFound
+               | NoRootFound
+               | NoCorpusFound
+               | NoUserFound
+               | MkNode
+               | UserNoParent
+               | HasParent
+               | ManyParents
+               | NegativeId
+               | NotImplYet
+               | ManyNodeUsers
+  deriving (Show)
+
+class HasNodeError e where
+  _NodeError :: Prism' e NodeError
+
+nodeError :: (MonadError e m, HasNodeError e) => NodeError -> m a
+nodeError ne = throwError $ _NodeError # ne
+
+catchNodeError :: (MonadError e m, HasNodeError e) => m a -> (NodeError -> m a) -> m a
+catchNodeError f g = catchError f (\e -> maybe (throwError e) g (e ^? _NodeError))

src/Gargantext/Database/Query/Node.hs

+{-|
+Module      : Gargantext.Database.Tools.Node
+Description : Main Tools of Node to the database
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+-}
+
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+{-# OPTIONS_GHC -fno-warn-orphans        #-}
+
+{-# LANGUAGE Arrows                 #-}
+{-# LANGUAGE DeriveGeneric          #-}
+{-# LANGUAGE ConstraintKinds        #-}
+{-# LANGUAGE FlexibleContexts       #-}
+{-# LANGUAGE FlexibleInstances      #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE OverloadedStrings      #-}
+{-# LANGUAGE MultiParamTypeClasses  #-}
+{-# LANGUAGE NoImplicitPrelude      #-}
+{-# LANGUAGE RankNTypes             #-}
+{-# LANGUAGE TemplateHaskell        #-}
+{-# LANGUAGE TypeFamilies           #-}
+
+module Gargantext.Database.Query.Node where
+
+import Control.Arrow (returnA)
+import Control.Lens (set, view)
+import Control.Lens.TH (makeLensesWith, abbreviatedFields)
+import Data.Aeson
+import Data.Maybe (Maybe(..), fromMaybe)
+import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
+import Data.Text (Text)
+import Database.PostgreSQL.Simple.FromField (FromField, fromField)
+import GHC.Int (Int64)
+import Gargantext.Core.Types
+import Gargantext.Core.Types.Individu (User(..))
+import Gargantext.Database.Config (nodeTypeId)
+import Gargantext.Database.Node.Contact (HyperdataContact(..), arbitraryHyperdataContact)
+import Gargantext.Database.Query.Filter (limit', offset')
+import Gargantext.Database.Schema.Node
+import Gargantext.Database.Types.Errors
+import Gargantext.Database.Types.Node (NodeType(..), defaultCorpus, Hyperdata, HyperData(..))
+import Gargantext.Database.Utils
+import Gargantext.Prelude hiding (sum, head)
+import Gargantext.Viz.Graph (HyperdataGraph(..))
+import Opaleye hiding (FromField)
+import Opaleye.Internal.QueryArr (Query)
+import Prelude hiding (null, id, map, sum)
+
+
+pgNodeId :: NodeId -> Column PGInt4
+pgNodeId = pgInt4 . id2int
+
+queryNodeSearchTable :: Query NodeSearchRead
+queryNodeSearchTable = queryTable nodeTableSearch
+
+selectNode :: Column PGInt4 -> Query NodeRead
+selectNode id = proc () -> do
+    row <- queryNodeTable -< ()
+    restrict -< _node_id row .== id
+    returnA -< row
+
+
+
+runGetNodes :: Query NodeRead -> Cmd err [Node HyperdataAny]
+runGetNodes = runOpaQuery
+
+------------------------------------------------------------------------
+------------------------------------------------------------------------
+-- | order by publication date
+-- Favorites (Bool), node_ngrams
+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
+
+selectNodesWith' :: ParentId -> Maybe NodeType -> Query NodeRead
+selectNodesWith' parentId maybeNodeType = proc () -> do
+    node <- (proc () -> do
+      row@(Node _ typeId _ parentId' _ _ _) <- queryNodeTable -< ()
+      restrict -< parentId' .== (pgNodeId parentId)
+
+      let typeId' = maybe 0 nodeTypeId maybeNodeType
+
+      restrict -< if typeId' > 0
+                     then typeId   .== (pgInt4 (typeId' :: Int))
+                     else (pgBool True)
+      returnA  -< row ) -< ()
+    returnA -< node
+
+deleteNode :: NodeId -> Cmd err Int
+deleteNode n = mkCmd $ \conn ->
+  fromIntegral <$> runDelete conn nodeTable
+                 (\(Node n_id _ _ _ _ _ _) -> n_id .== pgNodeId n)
+
+deleteNodes :: [NodeId] -> Cmd err Int
+deleteNodes ns = mkCmd $ \conn ->
+  fromIntegral <$> runDelete conn nodeTable
+                   (\(Node n_id _ _ _ _ _ _) -> in_ ((map pgNodeId ns)) n_id)
+
+-- TODO: NodeType should match with `a'
+getNodesWith :: JSONB a => NodeId -> proxy a -> Maybe NodeType
+             -> Maybe Offset -> Maybe Limit -> Cmd err [Node a]
+getNodesWith parentId _ nodeType maybeOffset maybeLimit =
+    runOpaQuery $ selectNodesWith parentId nodeType maybeOffset maybeLimit
+
+-- TODO: Why is the second parameter ignored?
+-- TODO: Why not use getNodesWith?
+getNodesWithParentId :: (Hyperdata a, QueryRunnerColumnDefault PGJsonb a)
+                     => Maybe NodeId
+                     -> Cmd err [Node a]
+getNodesWithParentId n = runOpaQuery $ selectNodesWithParentID n'
+  where
+    n' = case n of
+      Just n'' -> n''
+      Nothing  -> 0
+
+------------------------------------------------------------------------
+getDocumentsV3WithParentId :: NodeId -> Cmd err [Node HyperdataDocumentV3]
+getDocumentsV3WithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeDocument)
+
+-- TODO: merge with getDocumentsWithParentId by having a class IsHyperdataDocument
+getDocumentsWithParentId :: NodeId -> Cmd err [Node HyperdataDocument]
+getDocumentsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeDocument)
+
+getListsModelWithParentId :: NodeId -> Cmd err [Node HyperdataListModel]
+getListsModelWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeListModel)
+
+getCorporaWithParentId :: NodeId -> Cmd err [Node HyperdataCorpus]
+getCorporaWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeCorpus)
+
+------------------------------------------------------------------------
+selectNodesWithParentID :: NodeId -> Query NodeRead
+selectNodesWithParentID n = proc () -> do
+    row@(Node _ _ _ parent_id _ _ _) <- queryNodeTable -< ()
+    restrict -< parent_id .== (pgNodeId n)
+    returnA -< row
+
+selectNodesWithType :: Column PGInt4 -> Query NodeRead
+selectNodesWithType type_id = proc () -> do
+    row@(Node _ tn _ _ _ _ _) <- queryNodeTable -< ()
+    restrict -< tn .== type_id
+    returnA -< row
+
+type JSONB = QueryRunnerColumnDefault PGJsonb
+
+
+getNode :: NodeId -> Cmd err (Node Value)
+getNode nId = fromMaybe (error $ "Node does not exist: " <> show nId) . headMay
+             <$> runOpaQuery (limit 1 $ selectNode (pgNodeId nId))
+
+getNodeWith :: JSONB a => NodeId -> proxy a -> Cmd err (Node a)
+getNodeWith nId _ = do
+    fromMaybe (error $ "Node does not exist: " <> show nId) . headMay
+             <$> runOpaQuery (limit 1 $ selectNode (pgNodeId nId))
+
+
+getNodePhylo :: NodeId -> Cmd err (Node HyperdataPhylo)
+getNodePhylo nId = do
+    fromMaybe (error $ "Node Phylo does not exist: " <> show nId) . headMay
+             <$> runOpaQuery (limit 1 $ selectNode (pgNodeId nId))
+
+
+getNodesWithType :: Column PGInt4 -> Cmd err [Node HyperdataDocument]
+getNodesWithType = runOpaQuery . selectNodesWithType
+
+------------------------------------------------------------------------
+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
+------------------------------------------------------------------------
+defaultFolder :: HyperdataCorpus
+defaultFolder = defaultCorpus
+
+nodeFolderW :: Maybe Name -> Maybe HyperdataCorpus -> ParentId -> UserId -> NodeWrite
+nodeFolderW maybeName maybeFolder pid = node NodeFolder name folder (Just pid)
+  where
+    name   = maybe "Folder" identity maybeName
+    folder = maybe defaultFolder identity maybeFolder
+------------------------------------------------------------------------
+nodeCorpusW :: Maybe Name -> Maybe HyperdataCorpus -> ParentId -> UserId -> NodeWrite
+nodeCorpusW maybeName maybeCorpus pId = node NodeCorpus name corpus (Just pId)
+  where
+    name   = maybe "Corpus" identity maybeName
+    corpus = maybe defaultCorpus identity maybeCorpus
+                   --------------------------
+defaultDocument :: HyperdataDocument
+defaultDocument = hyperdataDocument
+
+nodeDocumentW :: Maybe Name -> Maybe HyperdataDocument -> CorpusId -> UserId -> NodeWrite
+nodeDocumentW maybeName maybeDocument cId = node NodeDocument name doc (Just cId)
+  where
+    name = maybe "Document" identity maybeName
+    doc  = maybe defaultDocument identity maybeDocument
+------------------------------------------------------------------------
+defaultAnnuaire :: HyperdataAnnuaire
+defaultAnnuaire = HyperdataAnnuaire (Just "Title") (Just "Description")
+
+nodeAnnuaireW :: Maybe Name -> Maybe HyperdataAnnuaire -> ParentId -> UserId -> NodeWrite
+nodeAnnuaireW maybeName maybeAnnuaire pId = node NodeAnnuaire name annuaire (Just pId)
+  where
+    name     = maybe "Annuaire" identity maybeName
+    annuaire = maybe defaultAnnuaire identity maybeAnnuaire
+
+------------------------------------------------------------------------
+
+{-
+class IsNodeDb a where
+  data Node'' a :: *
+  data Hyper  a :: *
+
+instance IsNodeDb NodeType where
+  data 
+
+instance HasHyperdata NodeType where
+  data Hyper NodeType = HyperList   HyperdataList
+                      | HyperCorpus HyperdataCorpus
+
+  hasHyperdata nt = case nt of
+    NodeList   -> HyperList $ HyperdataList (Just "list")
+
+  unHyper h = case h of
+    HyperList h' -> h'
+
+--}
+
+
+class HasDefault a where
+  hasDefaultData :: a -> HyperData
+  hasDefaultName :: a -> Text
+
+instance HasDefault NodeType where
+  hasDefaultData nt = case nt of
+      NodeTexts -> HyperdataTexts (Just "Preferences")
+      NodeList  -> HyperdataList' (Just "Preferences")
+      NodeListCooc -> HyperdataList' (Just "Preferences")
+      _         -> undefined
+      --NodeAnnuaire -> HyperdataAnnuaire (Just "Title") (Just "Description")
+
+  hasDefaultName nt = case nt of
+      NodeTexts -> "Texts"
+      NodeList  -> "Lists"
+      NodeListCooc -> "Cooc"
+      _         -> undefined
+
+------------------------------------------------------------------------
+
+nodeDefault :: NodeType -> ParentId -> UserId -> NodeWrite
+nodeDefault nt parent = node nt name hyper (Just parent)
+  where
+    name  = (hasDefaultName nt)
+    hyper = (hasDefaultData nt)
+
+------------------------------------------------------------------------
+arbitraryListModel :: HyperdataListModel
+arbitraryListModel = HyperdataListModel (400,500) "data/models/test.model" (Just 0.83)
+
+mkListModelNode :: HasNodeError err => ParentId -> UserId -> Cmd err [NodeId]
+mkListModelNode p u = insertNodesR [nodeListModelW Nothing Nothing p u]
+
+nodeListModelW :: Maybe Name -> Maybe HyperdataListModel -> ParentId -> UserId -> NodeWrite
+nodeListModelW maybeName maybeListModel pId = node NodeListModel name list (Just pId)
+  where
+    name = maybe "List Model" identity maybeName
+    list = maybe arbitraryListModel identity maybeListModel
+
+------------------------------------------------------------------------
+arbitraryGraph :: HyperdataGraph
+arbitraryGraph = HyperdataGraph Nothing
+
+nodeGraphW :: Maybe Name -> Maybe HyperdataGraph -> ParentId -> UserId -> NodeWrite
+nodeGraphW maybeName maybeGraph pId = node NodeGraph name graph (Just pId)
+  where
+    name = maybe "Graph" identity maybeName
+    graph = maybe arbitraryGraph identity maybeGraph
+
+mkGraph :: ParentId -> UserId -> Cmd err [GraphId]
+mkGraph p u = insertNodesR [nodeGraphW Nothing Nothing p u]
+
+insertGraph :: ParentId -> UserId -> HyperdataGraph -> Cmd err [GraphId]
+insertGraph p u h = insertNodesR [nodeGraphW Nothing (Just h) p u]
+
+------------------------------------------------------------------------
+arbitraryPhylo :: HyperdataPhylo
+arbitraryPhylo = HyperdataPhylo Nothing Nothing
+
+nodePhyloW :: Maybe Name -> Maybe HyperdataPhylo -> ParentId -> UserId -> NodeWrite
+nodePhyloW maybeName maybePhylo pId = node NodePhylo name graph (Just pId)
+  where
+    name = maybe "Phylo" identity maybeName
+    graph = maybe arbitraryPhylo identity maybePhylo
+
+
+------------------------------------------------------------------------
+arbitraryDashboard :: HyperdataDashboard
+arbitraryDashboard = HyperdataDashboard (Just "Preferences") []
+------------------------------------------------------------------------
+
+node :: (ToJSON a, Hyperdata a) => NodeType -> Name -> a -> Maybe ParentId -> UserId -> NodeWrite
+node nodeType name hyperData parentId userId =
+  Node Nothing 
+       (pgInt4 typeId)
+       (pgInt4 userId)
+       (pgNodeId <$> parentId)
+       (pgStrictText name)
+       Nothing
+       (pgJSONB $ cs $ encode hyperData)
+    where
+      typeId = nodeTypeId nodeType
+
+                  -------------------------------
+insertNodes :: [NodeWrite] -> Cmd err Int64
+insertNodes ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeTable ns rCount Nothing
+
+insertNodesR :: [NodeWrite] -> Cmd err [NodeId]
+insertNodesR ns = mkCmd $ \conn ->
+  runInsert_ conn (Insert nodeTable ns (rReturning (\(Node i _ _ _ _ _ _) -> i)) Nothing)
+
+insertNodesWithParent :: Maybe ParentId -> [NodeWrite] -> Cmd err Int64
+insertNodesWithParent pid ns = insertNodes (set node_parentId (pgNodeId <$> pid) <$> ns)
+
+insertNodesWithParentR :: Maybe ParentId -> [NodeWrite] -> Cmd err [NodeId]
+insertNodesWithParentR pid ns = insertNodesR (set node_parentId (pgNodeId <$> pid) <$> ns)
+------------------------------------------------------------------------
+-- TODO Hierachy of Nodes
+-- post and get same types Node' and update if changes
+
+{- TODO semantic to achieve
+post c uid pid [ Node' NodeCorpus "name" "{}" []
+               , Node' NodeFolder "name" "{}" [Node' NodeCorpus "test 2" "" [ Node' NodeDocument "title" "metaData" []
+                                                                    , Node' NodeDocument "title" "jsonData" []
+                                                                    ]
+                                          ]
+               ]
+-}
+------------------------------------------------------------------------
+
+-- TODO
+-- currently this function removes the child relation
+-- needs a Temporary type between Node' and NodeWriteT
+node2table :: UserId -> Maybe ParentId -> Node' -> NodeWrite
+node2table uid pid (Node' nt txt v []) = Node Nothing (pgInt4 $ nodeTypeId nt) (pgInt4 uid) (fmap pgNodeId pid) (pgStrictText txt) Nothing (pgStrictJSONB $ cs $ encode v)
+node2table _ _ (Node' _ _ _ _) = panic "node2table: should not happen, Tree insert not implemented yet"
+
+
+
+data Node' = Node' { _n_type :: NodeType
+                   , _n_name :: Text
+                   , _n_data :: Value
+                   , _n_children :: [Node']
+                   } deriving (Show)
+
+mkNodes :: [NodeWrite] -> Cmd err Int64
+mkNodes ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeTable ns rCount Nothing
+
+mkNodeR :: [NodeWrite] -> Cmd err [NodeId]
+mkNodeR ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeTable ns (rReturning _node_id) Nothing
+
+------------------------------------------------------------------------
+
+data NewNode = NewNode { _newNodeId :: NodeId
+                       , _newNodeChildren :: [NodeId] }
+
+postNode :: HasNodeError err => UserId -> Maybe ParentId -> Node' -> Cmd err NewNode
+
+postNode uid pid (Node' nt txt v []) = do
+  pids <- mkNodeR [node2table uid pid (Node' nt txt v [])]
+  case pids of
+    [pid'] -> pure $ NewNode pid' []
+    _ -> nodeError ManyParents
+
+postNode uid pid (Node' NodeCorpus txt v ns) = do
+  NewNode pid' _ <- postNode uid pid (Node' NodeCorpus txt v [])
+  pids  <- mkNodeR (concat $ map (\n -> [childWith uid pid' n]) ns)
+  pure $ NewNode pid' pids
+
+postNode uid pid (Node' NodeAnnuaire txt v ns) = do
+  NewNode pid' _ <- postNode uid pid (Node' NodeAnnuaire txt v [])
+  pids  <- mkNodeR (concat $ map (\n -> [childWith uid pid' n]) ns)
+  pure $ NewNode pid' pids
+
+postNode uid pid (Node' NodeDashboard txt v ns) = do
+  NewNode pid' _ <- postNode uid pid (Node' NodeDashboard txt v [])
+  pids  <- mkNodeR (concat $ map (\n -> [childWith uid pid' n]) ns)
+  pure $ NewNode pid' pids
+
+postNode _ _ (Node' _ _ _ _) = nodeError NotImplYet
+
+
+childWith :: UserId -> ParentId -> Node' -> NodeWrite
+childWith uId pId (Node' NodeDocument txt v []) = node2table uId (Just pId) (Node' NodeDocument txt v [])
+childWith uId pId (Node' NodeContact  txt v []) = node2table uId (Just pId) (Node' NodeContact txt v [])
+childWith _   _   (Node' _        _   _ _) = panic "This NodeType can not be a child"
+
+
+-- =================================================================== --
+------------------------------------------------------------------------
+-- | TODO mk all others nodes
+mkNodeWithParent :: HasNodeError err
+                 => NodeType
+                 -> Maybe ParentId
+                 -> UserId
+                 -> Name
+                 -> Cmd err [NodeId]
+mkNodeWithParent NodeUser (Just _) _   _    = nodeError UserNoParent
+
+------------------------------------------------------------------------
+mkNodeWithParent NodeUser Nothing uId name =
+  insertNodesWithParentR Nothing [node NodeUser name fake_HyperdataUser Nothing uId]
+
+mkNodeWithParent _ Nothing _ _ = nodeError HasParent
+------------------------------------------------------------------------
+mkNodeWithParent NodeFolder (Just i) uId name =
+   insertNodesWithParentR (Just i) [node NodeFolder name hd Nothing uId]
+    where
+      hd = defaultFolder
+
+mkNodeWithParent NodeFolderPrivate (Just i) uId _ =
+   insertNodesWithParentR (Just i) [node NodeFolderPrivate "Private" hd Nothing uId]
+    where
+      hd = defaultFolder
+
+mkNodeWithParent NodeFolderShared (Just i) uId _ =
+   insertNodesWithParentR (Just i) [node NodeFolderShared "Shared" hd Nothing uId]
+    where
+      hd = defaultFolder
+
+mkNodeWithParent NodeFolderPublic (Just i) uId _ =
+   insertNodesWithParentR (Just i) [node NodeFolderPublic "Public" hd Nothing uId]
+    where
+      hd = defaultFolder
+
+mkNodeWithParent NodeTeam (Just i) uId _ =
+   insertNodesWithParentR (Just i) [node NodeTeam "Team" hd Nothing uId]
+    where
+      hd = defaultFolder
+------------------------------------------------------------------------
+mkNodeWithParent NodeCorpus (Just i) uId name =
+   insertNodesWithParentR (Just i) [node NodeCorpus name hd Nothing uId]
+    where
+      hd = defaultCorpus
+
+mkNodeWithParent NodeAnnuaire (Just i) uId name =
+   insertNodesWithParentR (Just i) [node NodeAnnuaire name hd Nothing uId]
+    where
+      hd = defaultAnnuaire
+
+mkNodeWithParent _ _ _ _       = nodeError NotImplYet
+------------------------------------------------------------------------
+-- =================================================================== --
+-- |
+-- CorpusDocument is a corpus made from a set of documents
+-- CorpusContact  is a corpus made from a set of contacts (syn of Annuaire)
+data CorpusType = CorpusDocument | CorpusContact
+
+class MkCorpus a
+  where
+    mk :: Maybe Name -> Maybe a -> ParentId -> UserId -> Cmd err [NodeId]
+
+instance MkCorpus HyperdataCorpus
+  where
+    mk n h p u = insertNodesR [nodeCorpusW n h p u]
+
+
+instance MkCorpus HyperdataAnnuaire
+  where
+    mk n h p u = insertNodesR [nodeAnnuaireW n h p u]
+
+
+getOrMkList :: HasNodeError err => ParentId -> UserId -> Cmd err ListId
+getOrMkList pId uId =
+  maybe (mkList' pId uId) (pure . view node_id) . headMay =<< getListsWithParentId pId
+    where
+      mkList' pId uId = maybe (nodeError MkNode) pure . headMay =<< mkNode NodeList pId uId
+
+-- | TODO remove defaultList
+defaultList :: HasNodeError err => CorpusId -> Cmd err ListId
+defaultList cId =
+  maybe (nodeError NoListFound) (pure . view node_id) . headMay =<< getListsWithParentId cId
+
+mkNode :: NodeType -> ParentId -> UserId -> Cmd err [NodeId]
+mkNode nt p u = insertNodesR [nodeDefault nt p u]
+
+mkDashboard :: ParentId -> UserId -> Cmd err [NodeId]
+mkDashboard p u = insertNodesR [nodeDashboardW Nothing Nothing p u]
+  where
+    nodeDashboardW :: Maybe Name -> Maybe HyperdataDashboard -> ParentId -> UserId -> NodeWrite
+    nodeDashboardW maybeName maybeDashboard pId = node NodeDashboard name dashboard (Just pId)
+      where
+        name = maybe "Board" identity maybeName
+        dashboard = maybe arbitraryDashboard identity maybeDashboard
+
+
+mkPhylo :: ParentId -> UserId -> Cmd err [NodeId]
+mkPhylo p u = insertNodesR [nodePhyloW Nothing Nothing p u]
+
+getListsWithParentId :: NodeId -> Cmd err [Node HyperdataList]
+getListsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeList)
+
+-- import Gargantext.Database.Node.UpdateOpaleye (updateHyperdata)
+-- updateNodeUser_fake :: NodeId -> Cmd err Int64
+-- updateNodeUser_fake n = updateHyperdata n fake_HyperdataUser
+

src/Gargantext/Database/Query/Tree.hs

+{-|
+Module      : Gargantext.Database.Tree
+Description : Tree of Resource Nodes built from Database
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+
+Let a Root Node, return the Tree of the Node as a directed acyclic graph
+(Tree).
+
+-}
+
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE RankNTypes        #-}
+
+module Gargantext.Database.Query.Tree
+  ( treeDB
+  , TreeError(..)
+  , HasTreeError(..)
+  , dbTree
+  , toNodeTree
+  , DbTreeNode
+  , isDescendantOf
+  , isIn
+  ) where
+
+import Control.Lens (Prism', (#), (^..), at, each, _Just, to)
+import Control.Monad.Error.Class (MonadError(throwError))
+import Data.Map (Map, fromListWith, lookup)
+import Data.Text (Text)
+import Database.PostgreSQL.Simple
+import Database.PostgreSQL.Simple.SqlQQ
+
+import Gargantext.Prelude
+import Gargantext.Core.Types.Main (NodeTree(..), Tree(..))
+import Gargantext.Database.Config (fromNodeTypeId, nodeTypeId)
+import Gargantext.Database.Types.Node (NodeId, NodeType, DocId, allNodeTypes)
+import Gargantext.Database.Utils (Cmd, runPGSQuery)
+import Gargantext.Database.Tools.Node
+import Gargantext.Database.Tools.User
+
+------------------------------------------------------------------------
+-- import Gargantext.Database.Utils (runCmdDev)
+-- treeTest :: IO (Tree NodeTree)
+-- treeTest = runCmdDev $ treeDB 347474
+------------------------------------------------------------------------
+
+mkRoot :: HasNodeError err
+       => User
+       -> Cmd err [RootId]
+mkRoot user = do
+
+  uid <- getUserId user
+
+  let una = "username"
+
+  case uid > 0 of
+     False -> nodeError NegativeId
+     True  -> do
+       rs <- mkNodeWithParent NodeUser Nothing uid una
+       _ <- case rs of
+         [r] -> do
+           _ <- mkNodeWithParent NodeFolderPrivate (Just r) uid una
+           _ <- mkNodeWithParent NodeFolderShared  (Just r) uid una
+           _ <- mkNodeWithParent NodeFolderPublic  (Just r) uid una
+           pure rs
+         _   -> pure rs
+       pure rs
+
+
+------------------------------------------------------------------------
+data TreeError = NoRoot | EmptyRoot | TooManyRoots
+  deriving (Show)
+
+class HasTreeError e where
+  _TreeError :: Prism' e TreeError
+
+treeError :: (MonadError e m, HasTreeError e) => TreeError -> m a
+treeError te = throwError $ _TreeError # te
+
+-- | Returns the Tree of Nodes in Database
+treeDB :: HasTreeError err => RootId -> [NodeType] -> Cmd err (Tree NodeTree)
+treeDB r nodeTypes = toTree =<< (toTreeParent <$> dbTree r nodeTypes)
+
+type RootId = NodeId
+type ParentId = NodeId
+------------------------------------------------------------------------
+toTree :: (MonadError e m, HasTreeError e)
+       => Map (Maybe ParentId) [DbTreeNode] -> m (Tree NodeTree)
+toTree m =
+    case lookup Nothing m of
+        Just [n] -> pure $ toTree' m n
+        Nothing  -> treeError NoRoot
+        Just []  -> treeError EmptyRoot
+        Just _   -> treeError TooManyRoots
+
+toTree' :: Map (Maybe ParentId) [DbTreeNode] -> DbTreeNode -> Tree NodeTree
+toTree' m n =
+  TreeN (toNodeTree n) $
+    m ^.. at (Just $ dt_nodeId n) . _Just . each . to (toTree' m)
+
+------------------------------------------------------------------------
+toNodeTree :: DbTreeNode -> NodeTree
+toNodeTree (DbTreeNode nId tId _ n) = NodeTree n nodeType nId
+  where
+    nodeType = fromNodeTypeId tId
+------------------------------------------------------------------------
+toTreeParent :: [DbTreeNode] -> Map (Maybe ParentId) [DbTreeNode]
+toTreeParent = fromListWith (<>) . map (\n -> (dt_parentId n, [n]))
+------------------------------------------------------------------------
+data DbTreeNode = DbTreeNode { dt_nodeId :: NodeId
+                             , dt_typeId :: Int
+                             , dt_parentId :: Maybe NodeId
+                             , dt_name     :: Text
+                             } deriving (Show)
+
+-- | Main DB Tree function
+-- TODO add typenames as parameters
+dbTree :: RootId -> [NodeType] -> Cmd err [DbTreeNode]
+dbTree rootId nodeTypes = map (\(nId, tId, pId, n) -> DbTreeNode nId tId pId n)
+  <$> runPGSQuery [sql|
+    WITH RECURSIVE
+        tree (id, typename, parent_id, name) AS
+        (
+          SELECT p.id, p.typename, p.parent_id, p.name
+          FROM nodes AS p
+          WHERE p.id = ?
+
+          UNION
+
+          SELECT c.id, c.typename, c.parent_id, c.name
+          FROM nodes AS c
+
+          INNER JOIN tree AS s ON c.parent_id = s.id
+           WHERE c.typename IN ?
+        )
+    SELECT * from tree;
+    |] (rootId, In typename)
+  where
+    typename = map nodeTypeId ns
+    ns = case nodeTypes of
+      [] -> allNodeTypes
+      -- [2, 20, 21, 22, 3, 5, 30, 31, 40, 7, 9, 90, 71]
+      _  -> nodeTypes
+
+isDescendantOf :: NodeId -> RootId -> Cmd err Bool
+isDescendantOf childId rootId = (== [Only True])
+  <$> runPGSQuery [sql|
+                  BEGIN ;
+                  SET TRANSACTION READ ONLY;
+                  COMMIT;
+
+                  WITH RECURSIVE
+      tree (id, parent_id) AS
+      (
+        SELECT c.id, c.parent_id
+        FROM nodes AS c
+        WHERE c.id = ?
+
+        UNION
+
+        SELECT p.id, p.parent_id
+        FROM nodes AS p
+        INNER JOIN tree AS t ON t.parent_id = p.id
+
+      )
+  SELECT COUNT(*) = 1 from tree AS t
+  WHERE t.id = ?;
+  |] (childId, rootId)
+
+-- TODO should we check the category?
+isIn :: NodeId -> DocId -> Cmd err Bool
+isIn cId docId = ( == [Only True])
+  <$> runPGSQuery [sql| SELECT COUNT(*) = 1
+    FROM nodes_nodes nn
+      WHERE nn.node1_id = ?
+        AND nn.node2_id = ?;
+  |] (cId, docId)
+
+

src/Gargantext/Database/Query/Tree/Root.hs

+{-|
+Module      : Gargantext.Database.Root
+Description : Main requests to get root of users
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+-}
+
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+{-# OPTIONS_GHC -fno-warn-orphans        #-}
+
+{-# LANGUAGE Arrows                 #-}
+{-# LANGUAGE DeriveGeneric          #-}
+{-# LANGUAGE ConstraintKinds        #-}
+{-# LANGUAGE FlexibleContexts       #-}
+{-# LANGUAGE FlexibleInstances      #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE MultiParamTypeClasses  #-}
+{-# LANGUAGE NoImplicitPrelude      #-}
+{-# LANGUAGE RankNTypes             #-}
+{-# LANGUAGE TemplateHaskell        #-}
+
+module Gargantext.Database.Query.Tree.Root where
+
+import Control.Arrow (returnA)
+import Gargantext.Core.Types.Individu (User(..))
+import Gargantext.Database.Config (nodeTypeId)
+import Gargantext.Database.Node.User (HyperdataUser)
+import Gargantext.Database.Schema.Node (NodeRead)
+import Gargantext.Database.Schema.Node (queryNodeTable)
+import Gargantext.Database.Schema.User (queryUserTable, UserPoly(..))
+import Gargantext.Database.Types.Node (Node, NodePoly(..), NodeType(NodeUser))
+import Gargantext.Database.Utils (Cmd, runOpaQuery)
+import Gargantext.Prelude
+import Opaleye (restrict, (.==), Query)
+import Opaleye.PGTypes (pgStrictText, pgInt4)
+
+getRoot :: User -> Cmd err [Node HyperdataUser]
+getRoot = runOpaQuery . selectRoot
+
+selectRoot :: User -> Query NodeRead
+selectRoot (UserName username) = proc () -> do
+    row   <- queryNodeTable -< ()
+    users <- queryUserTable -< ()
+    restrict -< _node_typename row   .== (pgInt4 $ nodeTypeId NodeUser)
+    restrict -< user_username  users .== (pgStrictText username)
+    restrict -< _node_userId   row   .== (user_id users)
+    returnA  -< row
+
+selectRoot (UserDBId uid) = proc () -> do
+    row   <- queryNodeTable -< ()
+    restrict -< _node_typename row   .== (pgInt4 $ nodeTypeId NodeUser)
+    restrict -< _node_userId   row   .== (pgInt4 uid)
+    returnA  -< row
+

src/Gargantext/Database/Query/User.hs

+{-|
+Module      : Gargantext.Database.user
+Description : User Database management tools
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+
+Functions to deal with users, database side.
+-}
+
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+{-# OPTIONS_GHC -fno-warn-orphans        #-}
+
+{-# LANGUAGE TemplateHaskell             #-}
+{-# LANGUAGE FlexibleContexts            #-}
+{-# LANGUAGE FlexibleInstances           #-}
+{-# LANGUAGE MultiParamTypeClasses       #-}
+{-# LANGUAGE FunctionalDependencies      #-}
+{-# LANGUAGE Arrows                      #-}
+{-# LANGUAGE NoImplicitPrelude           #-}
+{-# LANGUAGE OverloadedStrings           #-}
+{-# LANGUAGE RankNTypes                  #-}
+
+module Gargantext.Database.Query.Tools.User
+  where
+
+import Control.Arrow (returnA)
+import Control.Lens.TH (makeLensesWith, abbreviatedFields)
+import Data.Eq(Eq(..))
+import Data.List (find)
+import Data.Maybe (Maybe)
+import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
+import Data.Text (Text)
+import Data.Time (UTCTime)
+import GHC.Show(Show(..))
+import Gargantext.Core.Types.Individu (Username, arbitraryUsername, User(..), UserId)
+import Gargantext.Database.Types.Errors
+import Gargantext.Database.Schema.User
+import Gargantext.Database.Utils
+import Gargantext.Prelude
+import Opaleye
+
+------------------------------------------------------------------------
+-- TODO: on conflict, nice message
+insertUsers :: [UserWrite] -> Cmd err Int64
+insertUsers us = mkCmd $ \c -> runInsert_ c insert
+  where
+    insert = Insert userTable us rCount Nothing
+
+
+gargantextUser :: Username -> UserWrite
+gargantextUser u = UserDB (Nothing) (pgStrictText "password")
+                         (Nothing) (pgBool True) (pgStrictText u)
+                         (pgStrictText "first_name")
+                         (pgStrictText "last_name")
+                         (pgStrictText "e@mail")
+                         (pgBool True) (pgBool True) (Nothing)
+
+insertUsersDemo :: Cmd err Int64
+insertUsersDemo = insertUsers $ map (\u -> gargantextUser u) arbitraryUsername
+
+------------------------------------------------------------------
+queryUserTable :: Query UserRead
+queryUserTable = queryTable userTable
+
+selectUsersLight :: Query UserRead
+selectUsersLight = proc () -> do
+      row@(UserDB i _p _ll _is _un _fn _ln _m _iff _ive _dj) <- queryUserTable -< ()
+      restrict -< i .== 1
+      --returnA -< User i p ll is un fn ln m iff ive dj
+      returnA -< row
+------------------------------------------------------------------
+-- | Select User with some parameters
+-- Not optimized version
+userWith :: (Eq a1, Foldable t) => (a -> a1) -> a1 -> t a -> Maybe a
+userWith f t xs = find (\x -> f x == t) xs
+
+-- | Select User with Username
+userWithUsername :: Text -> [UserDB] -> Maybe UserDB
+userWithUsername t xs = userWith user_username t xs
+
+userWithId :: Int -> [UserDB] -> Maybe UserDB
+userWithId t xs = userWith user_id t xs
+
+userLightWithUsername :: Text -> [UserLight] -> Maybe UserLight
+userLightWithUsername t xs = userWith userLight_username t xs
+
+userLightWithId :: Int -> [UserLight] -> Maybe UserLight
+userLightWithId t xs = userWith userLight_id t xs
+
+
+instance QueryRunnerColumnDefault PGTimestamptz (Maybe UTCTime) where
+  queryRunnerColumnDefault = fieldQueryRunnerColumn
+
+
+users :: Cmd err [UserDB]
+users = runOpaQuery queryUserTable
+
+usersLight :: Cmd err [UserLight]
+usersLight = map toUserLight <$> users
+
+getUser :: Username -> Cmd err (Maybe UserLight)
+getUser u = userLightWithUsername u <$> usersLight
+