[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/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
+