2 Module : Gargantext.Database.Node
3 Description : Main requests of Node to the database
4 Copyright : (c) CNRS, 2017-Present
5 License : AGPL + CECILL v3
6 Maintainer : team@gargantext.org
7 Stability : experimental
11 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
12 {-# OPTIONS_GHC -fno-warn-orphans #-}
14 {-# LANGUAGE Arrows #-}
15 {-# LANGUAGE DeriveGeneric #-}
16 {-# LANGUAGE ConstraintKinds #-}
17 {-# LANGUAGE FlexibleContexts #-}
18 {-# LANGUAGE FlexibleInstances #-}
19 {-# LANGUAGE FunctionalDependencies #-}
20 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
21 {-# LANGUAGE OverloadedStrings #-}
22 {-# LANGUAGE MultiParamTypeClasses #-}
23 {-# LANGUAGE NoImplicitPrelude #-}
24 {-# LANGUAGE TemplateHaskell #-}
26 module Gargantext.Database.Node where
28 import Data.Text (pack)
29 import GHC.Int (Int64)
30 import Control.Lens (set)
32 import Data.Time (UTCTime)
33 import Database.PostgreSQL.Simple.FromField ( Conversion
34 , ResultError(ConversionFailed)
39 import Prelude hiding (null, id, map, sum)
41 import Gargantext.Core (Lang(..))
42 import Gargantext.Core.Types
43 import Gargantext.Database.Types.Node (NodeType, defaultCorpus)
44 import Gargantext.Database.Queries
45 import Gargantext.Database.Config (nodeTypeId)
46 import Gargantext.Prelude hiding (sum)
48 import Database.PostgreSQL.Simple.Internal (Field)
49 import Control.Applicative (Applicative)
50 import Control.Arrow (returnA)
51 import Control.Lens.TH (makeLensesWith, abbreviatedFields)
52 import Control.Monad.IO.Class
53 import Control.Monad.Reader
55 import Data.Maybe (Maybe, fromMaybe)
56 import Data.Text (Text)
57 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
58 import Data.Typeable (Typeable)
60 import qualified Data.ByteString as DB
61 import qualified Data.ByteString.Lazy as DBL
62 import Data.ByteString (ByteString)
64 import Database.PostgreSQL.Simple (Connection)
65 import Opaleye hiding (FromField)
66 import Opaleye.Internal.QueryArr (Query)
67 import qualified Data.Profunctor.Product as PP
69 ------------------------------------------------------------------------
70 {- | Reader Monad reinvented here:
72 newtype Cmd a = Cmd { unCmd :: Connection -> IO a }
74 instance Monad Cmd where
75 return a = Cmd $ \_ -> return a
77 m >>= f = Cmd $ \c -> do
81 newtype Cmd a = Cmd (ReaderT Connection IO a)
82 deriving (Functor, Applicative, Monad, MonadReader Connection, MonadIO)
84 runCmd :: Connection -> Cmd a -> IO a
85 runCmd c (Cmd f) = runReaderT f c
87 mkCmd :: (Connection -> IO a) -> Cmd a
90 ------------------------------------------------------------------------
95 ------------------------------------------------------------------------
96 instance FromField HyperdataCorpus where
97 fromField = fromField'
99 instance FromField HyperdataDocument where
100 fromField = fromField'
102 instance FromField HyperdataDocumentV3 where
103 fromField = fromField'
105 instance FromField HyperdataUser where
106 fromField = fromField'
107 ------------------------------------------------------------------------
108 instance QueryRunnerColumnDefault PGJsonb HyperdataDocument where
109 queryRunnerColumnDefault = fieldQueryRunnerColumn
111 instance QueryRunnerColumnDefault PGJsonb HyperdataDocumentV3 where
112 queryRunnerColumnDefault = fieldQueryRunnerColumn
114 instance QueryRunnerColumnDefault PGJsonb HyperdataCorpus where
115 queryRunnerColumnDefault = fieldQueryRunnerColumn
117 instance QueryRunnerColumnDefault PGJsonb HyperdataUser where
118 queryRunnerColumnDefault = fieldQueryRunnerColumn
119 ------------------------------------------------------------------------
121 fromField' :: (Typeable b, FromJSON b) => Field -> Maybe DB.ByteString -> Conversion b
122 fromField' field mb = do
123 v <- fromField field mb
126 valueToHyperdata v = case fromJSON v of
128 Error _err -> returnError ConversionFailed field "cannot parse hyperdata"
131 $(makeAdaptorAndInstance "pNode" ''NodePoly)
132 $(makeLensesWith abbreviatedFields ''NodePoly)
135 nodeTable :: Table NodeWrite NodeRead
136 nodeTable = Table "nodes" (pNode Node { _node_id = optional "id"
137 , _node_typename = required "typename"
138 , _node_userId = required "user_id"
139 , _node_parentId = required "parent_id"
140 , _node_name = required "name"
141 , _node_date = optional "date"
142 , _node_hyperdata = required "hyperdata"
143 -- , node_titleAbstract = optional "title_abstract"
148 nodeTable' :: Table (Maybe (Column PGInt4)
151 ,Maybe (Column PGInt4)
153 ,Maybe (Column PGTimestamptz)
161 ,(Column PGTimestamptz)
165 nodeTable' = Table "nodes" (PP.p7 ( optional "id"
166 , required "typename"
168 , optional "parent_id"
171 , required "hyperdata"
176 queryNodeTable :: Query NodeRead
177 queryNodeTable = queryTable nodeTable
179 selectNode :: Column PGInt4 -> Query NodeRead
180 selectNode id = proc () -> do
181 row <- queryNodeTable -< ()
182 restrict -< _node_id row .== id
185 runGetNodes :: Query NodeRead -> Cmd [Node Value]
186 runGetNodes q = mkCmd $ \conn -> runQuery conn q
188 ------------------------------------------------------------------------
189 selectRootUser :: UserId -> Query NodeRead
190 selectRootUser userId = proc () -> do
191 row <- queryNodeTable -< ()
192 restrict -< _node_userId row .== (pgInt4 userId)
193 restrict -< _node_typename row .== (pgInt4 $ nodeTypeId NodeUser)
196 getRoot :: UserId -> Cmd [Node HyperdataUser]
197 getRoot userId = mkCmd $ \conn -> runQuery conn (selectRootUser userId)
198 ------------------------------------------------------------------------
200 -- | order by publication date
201 -- Favorites (Bool), node_ngrams
202 selectNodesWith :: ParentId -> Maybe NodeType
203 -> Maybe Offset -> Maybe Limit -> Query NodeRead
204 selectNodesWith parentId maybeNodeType maybeOffset maybeLimit =
205 --offset' maybeOffset $ limit' maybeLimit $ orderBy (asc (hyperdataDocument_Publication_date . node_hyperdata)) $ selectNodesWith' parentId typeId
206 limit' maybeLimit $ offset' maybeOffset $ orderBy (asc _node_id) $ selectNodesWith' parentId maybeNodeType
208 selectNodesWith' :: ParentId -> Maybe NodeType -> Query NodeRead
209 selectNodesWith' parentId maybeNodeType = proc () -> do
210 node <- (proc () -> do
211 row@(Node _ typeId _ parentId' _ _ _) <- queryNodeTable -< ()
212 restrict -< parentId' .== (toNullable $ pgInt4 parentId)
214 let typeId' = maybe 0 nodeTypeId maybeNodeType
216 restrict -< if typeId' > 0
217 then typeId .== (pgInt4 (typeId' :: Int))
219 returnA -< row ) -< ()
223 --type Cmd' a = forall m. (MonadReader env m, HasConnection env, MonadIO m) => m a
226 -- deleteNode :: (MonadReader Connection m, MonadIO m) => Int -> m Int
227 -- deleteNode :: Int -> Cmd' Int
229 deleteNode :: Int -> Cmd Int
230 deleteNode n = mkCmd $ \conn ->
231 fromIntegral <$> runDelete conn nodeTable
232 (\(Node n_id _ _ _ _ _ _) -> n_id .== pgInt4 n)
234 deleteNodes :: [Int] -> Cmd Int
235 deleteNodes ns = mkCmd $ \conn ->
236 fromIntegral <$> runDelete conn nodeTable
237 (\(Node n_id _ _ _ _ _ _) -> in_ ((map pgInt4 ns)) n_id)
240 getNodesWith :: JSONB a => Connection -> Int -> proxy a -> Maybe NodeType
241 -> Maybe Offset -> Maybe Limit -> IO [Node a]
242 getNodesWith conn parentId _ nodeType maybeOffset maybeLimit =
243 runQuery conn $ selectNodesWith
244 parentId nodeType maybeOffset maybeLimit
248 getNodesWithParentId :: Int
249 -> Maybe Text -> Connection -> IO [Node Value]
250 getNodesWithParentId n _ conn = runQuery conn $ selectNodesWithParentID n
252 getNodesWithParentId' :: Int
253 -> Maybe Text -> Connection -> IO [Node Value]
254 getNodesWithParentId' n _ conn = runQuery conn $ selectNodesWithParentID n
257 ------------------------------------------------------------------------
258 getDocumentsV3WithParentId :: Connection -> Int -> IO [Node HyperdataDocumentV3]
259 getDocumentsV3WithParentId conn n = runQuery conn $ selectNodesWith' n (Just NodeDocument)
261 getDocumentsWithParentId :: Connection -> Int -> IO [Node HyperdataDocument]
262 getDocumentsWithParentId conn n = runQuery conn $ selectNodesWith' n (Just NodeDocument)
264 ------------------------------------------------------------------------
267 selectNodesWithParentID :: Int -> Query NodeRead
268 selectNodesWithParentID n = proc () -> do
269 row@(Node _ _ _ parent_id _ _ _) <- queryNodeTable -< ()
272 parent_id .== (toNullable $ pgInt4 n)
278 selectNodesWithType :: Column PGInt4 -> Query NodeRead
279 selectNodesWithType type_id = proc () -> do
280 row@(Node _ tn _ _ _ _ _) <- queryNodeTable -< ()
281 restrict -< tn .== type_id
284 type JSONB = QueryRunnerColumnDefault PGJsonb
286 getNode :: JSONB a => Connection -> Int -> proxy a -> IO (Node a)
287 getNode conn id _ = do
288 fromMaybe (error $ "Node does node exist: " <> show id) . headMay <$> runQuery conn (limit 1 $ selectNode (pgInt4 id))
291 getNodesWithType :: Connection -> Column PGInt4 -> IO [Node HyperdataDocument]
292 getNodesWithType conn type_id = do
293 runQuery conn $ selectNodesWithType type_id
296 ------------------------------------------------------------------------
298 -- TODO Classe HasDefault where
299 -- default NodeType = Hyperdata
300 ------------------------------------------------------------------------
301 type NodeWrite' = NodePoly (Maybe Int) Int Int (Maybe ParentId) Text (Maybe UTCTime) ByteString
302 ------------------------------------------------------------------------
303 defaultUser :: HyperdataUser
304 defaultUser = HyperdataUser (Just $ (pack . show) EN)
306 nodeUserW :: Maybe Name -> Maybe HyperdataUser -> UserId -> NodeWrite'
307 nodeUserW maybeName maybeHyperdata = node NodeUser name (Hyperdata user) Nothing
309 name = maybe "User" identity maybeName
310 user = maybe defaultUser identity maybeHyperdata
311 ------------------------------------------------------------------------
312 defaultFolder :: HyperdataFolder
313 defaultFolder = HyperdataFolder (Just "Markdown Description")
315 nodeFolderW :: Maybe Name -> Maybe HyperdataFolder -> ParentId -> UserId -> NodeWrite'
316 nodeFolderW maybeName maybeFolder pid = node NodeFolder name (Hyperdata folder) (Just pid)
318 name = maybe "Folder" identity maybeName
319 folder = maybe defaultFolder identity maybeFolder
320 ------------------------------------------------------------------------
322 nodeCorpusW :: Maybe Name -> Maybe HyperdataCorpus -> ParentId -> UserId -> NodeWrite'
323 nodeCorpusW maybeName maybeCorpus pId = node NodeCorpus name (Hyperdata corpus) (Just pId)
325 name = maybe "Corpus" identity maybeName
326 corpus = maybe defaultCorpus identity maybeCorpus
327 --------------------------
328 defaultDocument :: HyperdataDocument
329 defaultDocument = hyperdataDocument
331 nodeDocumentW :: Maybe Name -> Maybe HyperdataDocument -> CorpusId -> UserId -> NodeWrite'
332 nodeDocumentW maybeName maybeDocument cId = node NodeDocument name (Hyperdata doc) (Just cId)
334 name = maybe "Document" identity maybeName
335 doc = maybe defaultDocument identity maybeDocument
336 ------------------------------------------------------------------------
337 defaultAnnuaire :: HyperdataAnnuaire
338 defaultAnnuaire = HyperdataAnnuaire (Just "Title") (Just "Description")
340 nodeAnnuaireW :: Maybe Name -> Maybe HyperdataAnnuaire -> ParentId -> UserId -> NodeWrite'
341 nodeAnnuaireW maybeName maybeAnnuaire pId = node NodeAnnuaire name (Hyperdata annuaire) (Just pId)
343 name = maybe "Annuaire" identity maybeName
344 annuaire = maybe defaultAnnuaire identity maybeAnnuaire
345 --------------------------
346 defaultContact :: HyperdataContact
347 defaultContact = HyperdataContact (Just "Name") (Just "email@here")
349 nodeContactW :: Maybe Name -> Maybe HyperdataContact -> AnnuaireId -> UserId -> NodeWrite'
350 nodeContactW maybeName maybeContact aId = node NodeContact name (Hyperdata contact) (Just aId)
352 name = maybe "Contact" identity maybeName
353 contact = maybe defaultContact identity maybeContact
354 ------------------------------------------------------------------------
355 ------------------------------------------------------------------------
356 node :: ToJSON a => NodeType -> Name -> Hyperdata a -> Maybe ParentId -> UserId -> NodeWrite'
357 node nodeType name hyperData parentId userId = Node Nothing typeId userId parentId name Nothing byteData
359 typeId = nodeTypeId nodeType
360 byteData = DB.pack $ DBL.unpack $ encode $ unHyperdata hyperData
362 -------------------------------
363 node2row :: (Functor maybe1, Functor maybe2, Functor maybe3) =>
364 NodePoly (maybe2 Int) Int Int (maybe1 Int)
365 Text (maybe3 UTCTime) ByteString
366 -> (maybe2 (Column PGInt4), Column PGInt4, Column PGInt4, maybe1 (Column PGInt4)
367 , Column PGText, maybe3 (Column PGTimestamptz), Column PGJsonb)
368 node2row (Node id tn ud pid nm dt hp) = ((pgInt4 <$> id)
376 ------------------------------------------------------------------------
377 insertNodesR' :: [NodeWrite'] -> Cmd [Int]
378 insertNodesR' ns = mkCmd $ \c -> insertNodesR ns c
380 insertNodes :: [NodeWrite'] -> Connection -> IO Int64
381 insertNodes ns conn = runInsertMany conn nodeTable' (map node2row ns)
383 insertNodesR :: [NodeWrite'] -> Connection -> IO [Int]
384 insertNodesR ns conn = runInsertManyReturning conn nodeTable' (map node2row ns) (\(i,_,_,_,_,_,_) -> i)
385 -------------------------
386 insertNodesWithParent :: Maybe ParentId -> [NodeWrite'] -> Connection -> IO Int64
387 insertNodesWithParent pid ns conn = insertNodes (map (set node_parentId pid) ns) conn
389 insertNodesWithParentR :: Maybe ParentId -> [NodeWrite'] -> Connection -> IO [Int]
390 insertNodesWithParentR pid ns conn = insertNodesR (map (set node_parentId pid) ns) conn
391 ------------------------------------------------------------------------
392 -- TODO Hierachy of Nodes
393 -- post and get same types Node' and update if changes
395 {- TODO semantic to achieve
396 post c uid pid [ Node' NodeCorpus "name" "{}" []
397 , Node' NodeFolder "name" "{}" [Node' NodeCorpus "test 2" "" [ Node' NodeDocument "title" "metaData" []
398 , Node' NodeDocument "title" "jsonData" []
403 ------------------------------------------------------------------------
406 -- currently this function remove the child relation
407 -- needs a Temporary type between Node' and NodeWriteT
408 node2table :: UserId -> Maybe ParentId -> Node' -> NodeWriteT
409 node2table uid pid (Node' nt txt v []) = ( Nothing, (pgInt4$ nodeTypeId nt), (pgInt4 uid), (fmap pgInt4 pid)
410 , pgStrictText txt, Nothing, pgStrictJSONB $ DB.pack $ DBL.unpack $ encode v)
411 node2table _ _ (Node' _ _ _ _) = panic "node2table: should not happen, Tree insert not implemented yet"
414 data Node' = Node' { _n_type :: NodeType
417 , _n_children :: [Node']
421 type NodeWriteT = ( Maybe (Column PGInt4)
424 , Maybe (Column PGInt4)
426 , Maybe (Column PGTimestamptz)
431 mkNode' :: [NodeWriteT] -> Cmd Int64
432 mkNode' ns = mkCmd $ \conn -> runInsertMany conn nodeTable' ns
434 mkNodeR' :: [NodeWriteT] -> Cmd [Int]
435 mkNodeR' ns = mkCmd $ \conn -> runInsertManyReturning conn nodeTable' ns (\(i,_,_,_,_,_,_) -> i)
438 ------------------------------------------------------------------------
440 data NewNode = NewNode { _newNodeId :: Int
441 , _newNodeChildren :: [Int] }
444 postNode :: UserId -> Maybe ParentId -> Node' -> Cmd NewNode
445 postNode uid pid (Node' nt txt v []) = do
446 pids <- mkNodeR' [node2table uid pid (Node' nt txt v [])]
448 [pid] -> pure $ NewNode pid []
449 _ -> panic "postNode: only one pid expected"
451 postNode uid pid (Node' NodeCorpus txt v ns) = do
452 NewNode pid' _ <- postNode uid pid (Node' NodeCorpus txt v [])
453 pids <- mkNodeR' (concat $ map (\n -> [childWith uid pid' n]) ns)
454 pure $ NewNode pid' pids
456 postNode uid pid (Node' NodeAnnuaire txt v ns) = do
457 NewNode pid' _ <- postNode uid pid (Node' NodeAnnuaire txt v [])
458 pids <- mkNodeR' (concat $ map (\n -> [childWith uid pid' n]) ns)
459 pure $ NewNode pid' pids
460 postNode _ _ (Node' _ _ _ _) = panic "TODO: postNode for this type not implemented yet"
463 childWith :: UserId -> ParentId -> Node' -> NodeWriteT
464 childWith uId pId (Node' NodeDocument txt v []) = node2table uId (Just pId) (Node' NodeDocument txt v [])
465 childWith uId pId (Node' NodeContact txt v []) = node2table uId (Just pId) (Node' NodeContact txt v [])
466 childWith _ _ (Node' _ _ _ _) = panic "This NodeType can not be a child"
469 -- TODO: remove hardcoded userId (with Reader)
470 -- TODO: user Reader in the API and adapt this function
474 mk :: Connection -> NodeType -> Maybe ParentId -> Text -> IO [Int]
475 mk c nt pId name = mk' c nt userId pId name
477 mk' :: Connection -> NodeType -> UserId -> Maybe ParentId -> Text -> IO [Int]
478 mk' c nt uId pId name = map fromIntegral <$> insertNodesWithParentR pId [node nt name hd pId uId] c
480 hd = Hyperdata (HyperdataUser (Just $ (pack . show) EN))
484 mk'' :: NodeType -> Maybe ParentId -> UserId -> Name -> Cmd [Int]
485 mk'' NodeUser Nothing uId name = mkCmd $ \c -> mk' c NodeUser uId Nothing name
486 mk'' NodeUser _ _ _ = panic "NodeUser can not has a parent"
487 mk'' _ Nothing _ _ = panic "NodeType needs a parent"
488 mk'' nt pId uId name = mkCmd $ \c -> mk' c nt uId pId name
490 mkRoot :: UserId -> Cmd [Int]
491 mkRoot uId = case uId > 0 of
492 False -> panic "UserId <= 0"
493 True -> mk'' NodeUser Nothing uId ("User Node : " <> (pack . show) uId)
495 mkCorpus :: Maybe Name -> Maybe HyperdataCorpus -> ParentId -> UserId -> Cmd [Int]
496 mkCorpus n h p u = insertNodesR' [nodeCorpusW n h p u]