Skip to content

H
haskell-gargantext
Commit 8438f4b7 authored by Alexandre Delanoë's avatar Alexandre Delanoë
Browse files
Options

[BASQHL] refacto.

parent 06805289
Hide whitespace changes
Inline Side-by-side
Showing with 110 additions and 83 deletions
src/Gargantext/API/Node.hs
View file @ 8438f4b7
......@@ -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
View file @ 8438f4b7
......@@ -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
View file @ 8438f4b7
......@@ -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
View file @ 8438f4b7
......@@ -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
View file @ 8438f4b7
......@@ -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
View file @ 8438f4b7
......@@ -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
View file @ 8438f4b7
......@@ -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)
......
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