[BASQHL] refacto.

src/Gargantext/API/Node.hs

@@ -102,7 +102,7 @@ type NodeAPI   = Get '[JSON] (Node Value)
                            :> Put     '[JSON] [Int]
              :<|> Summary " PostNode Node with ParentId as {id}"
                            :> ReqBody '[JSON] PostNode
-                           :> Post    '[JSON] Int
+                           :> Post    '[JSON] [Int]
              :<|> Put    '[JSON] Int
              :<|> Delete '[JSON] Int
              :<|> "children" :> Summary " Summary children"
@@ -186,8 +186,8 @@ rename c nId (RenameNode name) = liftIO $ U.update (U.Rename nId name) c
 nodesAPI :: Connection -> [NodeId] -> Server NodesAPI
 nodesAPI conn ids = deleteNodes' conn ids
 
-postNode :: Connection -> NodeId -> PostNode -> Handler Int
-postNode c pId (PostNode name nt) = liftIO $ mk c nt pId name
+postNode :: Connection -> NodeId -> PostNode -> Handler [Int]
+postNode c pId (PostNode name nt) = liftIO $ mk c nt (Just pId) name
 
 putNode :: Connection -> NodeId -> Handler Int
 putNode = undefined -- TODO

src/Gargantext/Database/Bashql.hs

@@ -69,17 +69,18 @@ module Gargantext.Database.Bashql ( get
                                   , put
                                   , rename
                                   , tree
-                                  , mkCorpus, mkAnnuaire
+                                  -- , mkCorpus, mkAnnuaire
                                   , runCmd'
                                  )
     where
 
 import Control.Monad.Reader -- (Reader, ask)
 
+import Safe (lastMay)
 import Data.Text (Text)
 import Data.Aeson
 import Data.Aeson.Types
-import Data.List (last, concat)
+import Data.List (concat, last)
 
 import Gargantext.Core.Types
 import Gargantext.Database.Utils (connectGargandb)
@@ -124,16 +125,18 @@ tree p = do
 post :: PWD -> [NodeWrite'] -> Cmd Int64
 post [] _   = pure 0
 post _ []   = pure 0
-post pth ns = Cmd . ReaderT $ mkNode (last pth) ns
+post pth ns = Cmd . ReaderT $ mkNode (Just $ last pth) ns
 
 --postR :: PWD -> [NodeWrite'] -> Cmd [Int]
 --postR [] _ _ = pure [0]
 --postR _ [] _ = pure [0]
 --postR pth ns c = mkNodeR (last pth) ns c
 
+-- | WIP
+-- rm : mv to trash
+-- del : empty trash
 --rm :: Connection -> PWD -> [NodeId] -> IO Int
 --rm = del
-
 del :: [NodeId] -> Cmd Int
 del [] = pure 0
 del ns = deleteNodes ns
@@ -151,24 +154,32 @@ put u = mkCmd $ U.update u
 type Name = Text
 
 
-mkCorpus :: ToJSON a => Name -> (a -> Text) -> [a] -> Cmd NewNode
-mkCorpus name title ns = do
-  pid <- last <$> home
-  let uid = 1
-  postNode uid pid ( Node' NodeCorpus  name emptyObject
-                       (map (\n -> Node' Document (title n) (toJSON n) []) ns)
-                   )
-
--- |
--- import IMTClient as C
--- postAnnuaire "Annuaire IMT" (\n -> (maybe "" identity (C.prenom n)) <> " " <> (maybe "" identity (C.nom n))) (take 30 annuaire)
-mkAnnuaire :: ToJSON a => Name -> (a -> Text) -> [a] -> Cmd NewNode
-mkAnnuaire name title ns = do
-  pid <- last <$> home
-  let uid = 1
-  postNode uid pid ( Node' Annuaire  name emptyObject
-                       (map (\n -> Node' UserPage (title n) (toJSON n) []) ns)
-                   )
+--mkCorpus :: ToJSON a => Name -> (a -> Text) -> [a] -> Cmd NewNode
+--mkCorpus name title ns = do
+--  pid <- home
+--  
+--  let pid' = case lastMay pid of
+--        Nothing -> printDebug "No home for" name
+--        Just p  -> p
+--  
+--  let uid = 1
+--  postNode uid (Just pid') ( Node' NodeCorpus  name emptyObject
+--                       (map (\n -> Node' Document (title n) (toJSON n) []) ns)
+--                   )
+--
+---- |
+---- import IMTClient as C
+---- postAnnuaire "Annuaire IMT" (\n -> (maybe "" identity (C.prenom n)) <> " " <> (maybe "" identity (C.nom n))) (take 30 annuaire)
+--mkAnnuaire :: ToJSON a => Name -> (a -> Text) -> [a] -> Cmd NewNode
+--mkAnnuaire name title ns = do
+--  pid <- lastMay <$> home
+--  let pid' = case lastMay pid of
+--        Nothing -> printDebug "No home for" name
+--        Just p  -> p
+--  let uid = 1
+--  postNode uid (Just pid') ( Node' Annuaire  name emptyObject
+--                       (map (\n -> Node' UserPage (title n) (toJSON n) []) ns)
+--                   )
 
 --------------------------------------------------------------
 -- | 

src/Gargantext/Database/Flow.hs

@@ -27,30 +27,38 @@ authors
 -}
 
 {-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 module Gargantext.Database.Flow
     where
-
+import GHC.Base ((>>))
 import Data.Maybe (Maybe(..))
+import Gargantext.Core.Types (NodePoly(..))
 import Gargantext.Prelude
 import Gargantext.Database.Bashql (runCmd')
-import Gargantext.Database.Node (Cmd(..), getRootUser)
+import Gargantext.Database.Node (Cmd(..), getRoot, mkRoot)
 import Gargantext.Database.User (getUser, UserLight(..))
 import Gargantext.Database.Node.Document.Import (insertDocuments)
 
+--flow :: IO ()
 flow = do
-  gargantua_id <- runCmd' (getUser "gargantua")
-  -- createUser
-  userNode <- case gargantua_id of
-        Nothing     -> panic "no user"
-        Just userId -> runCmd' (getRootUser $ userLight_id userId)
+  masterUser <- runCmd' (getUser "gargantua")
+  
+  let masterUserId = case masterUser of
+        Nothing   -> panic "no user"
+        Just user -> userLight_id user
+        
+  root <- map node_id <$> runCmd' (getRoot masterUserId)
   
-  case userNode of
-        [] -> pure ()
-        _  -> pure ()
+  root' <- case root of
+        []  -> runCmd' (mkRoot masterUserId)
+        un  -> case length un >= 2 of
+                 True  -> panic "Error: more than 1 userNode / user"
+                 False -> pure root
+
+  printDebug "User Node : " root'
   
-  -- getOrMk
-  --rootId       <- runCmd' (getNodeWith userId nodeType)
+  pure ()
 {-
   rootId       <- mk NodeUser gargantua_id "Node Gargantua"
 
@@ -59,24 +67,11 @@ flow = do
   corpusId <- mk Corpus folderId (Name "WOS")  (Descr "WOS database description")
   
   docs <- parseDocuments WOS "doc/.."
-  ids <- addDocuments corpusId docs
+  ids  <- add (Documents corpusId) docs
 
   user_id <- runCmd' (get RootUser "alexandre")
+  rootUser_id <- runCmd' (getRootUser $ userLight_id user_id
+  corpusId <- mk Corpus 
 -}
 
 
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-

src/Gargantext/Database/Node.hs

@@ -23,7 +23,7 @@ Portability : POSIX
 
 module Gargantext.Database.Node where
 
-
+import Data.Text (pack)
 import GHC.Int (Int64)
 import Data.Maybe
 import Data.Time (UTCTime)
@@ -35,13 +35,13 @@ import Database.PostgreSQL.Simple.FromField ( Conversion
                                             )
 import Prelude hiding (null, id, map, sum)
 
+import Gargantext.Core (Lang(..))
 import Gargantext.Core.Types
 import Gargantext.Database.Types.Node (NodeType)
 import Gargantext.Database.Queries
 import Gargantext.Database.Config (nodeTypeId)
 import Gargantext.Prelude hiding (sum)
 
-
 import Database.PostgreSQL.Simple.Internal  (Field)
 import Control.Applicative (Applicative)
 import Control.Arrow (returnA)
@@ -153,7 +153,7 @@ nodeTable = Table "nodes" (pNode Node { node_id                = optional "id"
 nodeTable' :: Table (Maybe (Column PGInt4)
                     ,       Column PGInt4
                     ,       Column PGInt4
-                    ,       Column PGInt4
+                    ,Maybe (Column PGInt4)
                     ,       Column PGText
                     ,Maybe (Column PGTimestamptz)
                     ,       Column PGJsonb
@@ -170,7 +170,7 @@ nodeTable' :: Table (Maybe (Column PGInt4)
 nodeTable' = Table "nodes" (PP.p7 ( optional "id"
                                , required "typename"
                                , required "user_id"
-                               , required "parent_id"
+                               , optional "parent_id"
                                , required "name"
                                , optional "date"
                                , required "hyperdata"
@@ -198,8 +198,8 @@ selectRootUser userId = proc () -> do
     restrict -< node_typename row .== (pgInt4 $ nodeTypeId NodeUser)
     returnA -< row
 
-getRootUser :: UserId -> Cmd [Node HyperdataUser]
-getRootUser userId = mkCmd $ \conn -> runQuery conn (selectRootUser userId)
+getRoot :: UserId -> Cmd [Node HyperdataUser]
+getRoot userId = mkCmd $ \conn -> runQuery conn (selectRootUser userId)
 ------------------------------------------------------------------------
 
 -- | order by publication date
@@ -300,36 +300,34 @@ getNodesWithType conn type_id = do
 ------------------------------------------------------------------------
 -- Quick and dirty
 ------------------------------------------------------------------------
-type NodeWrite' = NodePoly (Maybe Int) Int Int (ParentId) Text (Maybe UTCTime) ByteString
+type NodeWrite' = NodePoly (Maybe Int) Int Int (Maybe ParentId) Text (Maybe UTCTime) ByteString
 
---node :: UserId -> ParentId -> NodeType -> Text -> Value -> NodeWrite'
-node :: UserId -> ParentId -> NodeType -> Text -> Value -> NodeWrite'
+node :: ToJSON a => UserId -> Maybe ParentId -> NodeType -> Text -> Hyperdata a -> NodeWrite'
 node userId parentId nodeType name nodeData = Node Nothing typeId userId parentId name Nothing byteData
   where
     typeId = nodeTypeId nodeType
-    byteData = DB.pack $ DBL.unpack $ encode nodeData
-
+    byteData = DB.pack $ DBL.unpack $ encode $ unHyperdata nodeData
 
 
-node2write :: (Functor f2, Functor f1) =>
-              Int -> NodePoly (f1 Int) Int Int parentId Text (f2 UTCTime) ByteString
-              -> (f1 (Column PGInt4), Column PGInt4, Column PGInt4,
-                  Column PGInt4, Column PGText, f2 (Column PGTimestamptz),
+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,
+                  maybe1 (Column PGInt4), Column PGText, maybe3 (Column PGTimestamptz),
                   Column PGJsonb)
 node2write pid (Node id tn ud _ nm dt hp) = ((pgInt4    <$> id)
                                          ,(pgInt4        tn)
                                          ,(pgInt4        ud)
-                                         ,(pgInt4        pid)
+                                         ,(pgInt4   <$> pid)
                                          ,(pgStrictText  nm)
                                          ,(pgUTCTime <$> dt)
                                          ,(pgStrictJSONB hp)
                                          )
 
 
-mkNode :: ParentId -> [NodeWrite'] -> Connection -> IO Int64
+mkNode :: Maybe ParentId -> [NodeWrite'] -> Connection -> IO Int64
 mkNode pid ns conn = runInsertMany conn nodeTable' $ map (node2write pid) ns
 
-mkNodeR :: ParentId -> [NodeWrite'] -> Connection -> IO [Int]
+mkNodeR :: Maybe ParentId -> [NodeWrite'] -> Connection -> IO [Int]
 mkNodeR pid ns conn = runInsertManyReturning conn nodeTable' (map (node2write pid) ns) (\(i,_,_,_,_,_,_) -> i)
 
 
@@ -350,8 +348,8 @@ post c uid pid [ Node' Corpus "name" "{}" []
 -- TODO
 -- currently this function remove the child relation
 -- needs a Temporary type between Node' and NodeWriteT
-node2table :: UserId -> ParentId -> Node' -> NodeWriteT
-node2table uid pid (Node' nt txt v []) = ( Nothing, (pgInt4$ nodeTypeId nt), (pgInt4 uid), (pgInt4 pid)
+node2table :: UserId -> Maybe ParentId -> Node' -> NodeWriteT
+node2table uid pid (Node' nt txt v []) = ( Nothing, (pgInt4$ nodeTypeId nt), (pgInt4 uid), (fmap pgInt4 pid)
                                          , pgStrictText txt, Nothing, pgStrictJSONB $ DB.pack $ DBL.unpack $ encode v)
 node2table _ _ (Node' _ _ _ _) = panic "node2table: should not happen, Tree insert not implemented yet"
 
@@ -364,10 +362,12 @@ data Node' = Node' { _n_type :: NodeType
 
 
 type NodeWriteT =  ( Maybe (Column PGInt4)
-                   , Column PGInt4, Column PGInt4
-                   , Column PGInt4, Column PGText
+                   ,        Column PGInt4
+                   ,        Column PGInt4
+                   , Maybe (Column PGInt4)
+                   ,        Column PGText
                    , Maybe (Column PGTimestamptz)
-                   , Column PGJsonb
+                   ,        Column PGJsonb
                    )
 
 
@@ -381,7 +381,7 @@ data NewNode = NewNode { _newNodeId :: Int
                        , _newNodeChildren :: [Int] }
 
 -- | postNode
-postNode :: UserId -> ParentId -> Node' -> Cmd NewNode
+postNode :: UserId -> Maybe ParentId -> Node' -> Cmd NewNode
 postNode uid pid (Node' nt txt v []) = do
   pids <- mkNodeR' [node2table uid pid (Node' nt txt v [])]
   case pids of
@@ -401,12 +401,30 @@ postNode _ _ (Node' _ _ _ _) = panic "TODO: postNode for this type not implement
 
 
 childWith :: UserId -> ParentId -> Node' -> NodeWriteT
-childWith uId pId (Node' Document txt v []) = node2table uId pId (Node' Document txt v [])
-childWith uId pId (Node' UserPage txt v []) = node2table uId pId (Node' UserPage txt v [])
+childWith uId pId (Node' Document txt v []) = node2table uId (Just pId) (Node' Document txt v [])
+childWith uId pId (Node' UserPage txt v []) = node2table uId (Just pId) (Node' UserPage txt v [])
 childWith _   _   (Node' _        _   _ _) = panic "This NodeType can not be a child"
 
 
-mk :: Connection -> NodeType -> ParentId -> Text -> IO Int
-mk c nt pId name  = fromIntegral <$> mkNode pId [node 1 pId nt name ""] c
+-- TODO: remove hardcoded userId (with Reader)
+-- TODO: user Reader in the API and adapt this function
+mk :: Connection -> NodeType -> Maybe ParentId -> Text -> IO [Int]
+mk c nt pId name  = mk' c nt 1 pId name
+
+mk' :: Connection -> NodeType -> UserId -> Maybe ParentId -> Text -> IO [Int]
+mk' c nt uId pId name  = map fromIntegral <$> mkNodeR pId [node uId pId nt name hd] c
+  where
+    hd = Hyperdata (HyperdataUser (Just $ (pack . show) EN))
+
+type Name = Text
 
+mk'' :: NodeType -> Maybe ParentId -> UserId -> Name -> Cmd [Int]
+mk'' NodeUser Nothing uId name  = mkCmd $ \c -> mk' c NodeUser uId Nothing name
+mk'' NodeUser _       _   _     = panic "NodeUser can not has a parent"
+mk'' _        Nothing _   _     = panic "NodeType needs a parent"
+mk'' nt       pId     uId name  = mkCmd $ \c -> mk' c nt uId pId name
 
+mkRoot :: UserId -> Cmd [Int]
+mkRoot uId = case uId > 0 of
+               False -> panic "UserId <= 0"
+               True  -> mk'' NodeUser Nothing uId ("User Node : " <> (pack . show) uId)

src/Gargantext/Database/Types/Node.hs

@@ -191,6 +191,9 @@ instance Arbitrary Resource where
 
 ------------------------------------------------------------------------
 
+data Hyperdata a = Hyperdata { unHyperdata :: a} 
+$(deriveJSON (unPrefix "") ''Hyperdata)
+
 data HyperdataCorpus = HyperdataCorpus { hyperdataCorpus_resources    :: [Resource]
                                        } deriving (Show, Generic)
 $(deriveJSON (unPrefix "hyperdataCorpus_") ''HyperdataCorpus)

src/Gargantext/Database/User.hs

@@ -32,7 +32,6 @@ import Data.Text (Text)
 import Data.Time (UTCTime)
 import GHC.Show(Show(..))
 import Opaleye
-import qualified Database.PostgreSQL.Simple as PGS
 
 import Gargantext.Prelude
 import Gargantext.Database.Node (Cmd(..), mkCmd, runCmd)

src/Gargantext/Text/Terms/Stop.hs

@@ -14,8 +14,9 @@ Main type here is String.
 -}
 
 {-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
 
-module Gargantext.Text.Terms.Stop (detectLang, detectLangs, stopList)
+module Gargantext.Text.Terms.Stop -- (detectLang, detectLangs, stopList)
   where
 
 import GHC.Base (Functor)