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, Hyperdata)
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 ------------------------------------------------------------------------
97 ------------------------------------------------------------------------
98 instance FromField HyperdataAny where
99 fromField = fromField'
101 instance FromField HyperdataCorpus where
102 fromField = fromField'
104 instance FromField HyperdataDocument where
105 fromField = fromField'
107 instance FromField HyperdataDocumentV3 where
108 fromField = fromField'
110 instance FromField HyperdataUser where
111 fromField = fromField'
113 instance FromField HyperdataAnnuaire where
114 fromField = fromField'
115 ------------------------------------------------------------------------
116 instance QueryRunnerColumnDefault PGJsonb HyperdataAny where
117 queryRunnerColumnDefault = fieldQueryRunnerColumn
119 instance QueryRunnerColumnDefault PGJsonb HyperdataDocument where
120 queryRunnerColumnDefault = fieldQueryRunnerColumn
122 instance QueryRunnerColumnDefault PGJsonb HyperdataDocumentV3 where
123 queryRunnerColumnDefault = fieldQueryRunnerColumn
125 instance QueryRunnerColumnDefault PGJsonb HyperdataCorpus where
126 queryRunnerColumnDefault = fieldQueryRunnerColumn
128 instance QueryRunnerColumnDefault PGJsonb HyperdataUser where
129 queryRunnerColumnDefault = fieldQueryRunnerColumn
131 instance QueryRunnerColumnDefault PGJsonb HyperdataAnnuaire where
132 queryRunnerColumnDefault = fieldQueryRunnerColumn
133 ------------------------------------------------------------------------
135 fromField' :: (Typeable b, FromJSON b) => Field -> Maybe DB.ByteString -> Conversion b
136 fromField' field mb = do
137 v <- fromField field mb
140 valueToHyperdata v = case fromJSON v of
142 Error _err -> returnError ConversionFailed field "cannot parse hyperdata"
145 $(makeAdaptorAndInstance "pNode" ''NodePoly)
146 $(makeLensesWith abbreviatedFields ''NodePoly)
149 nodeTable :: Table NodeWrite NodeRead
150 nodeTable = Table "nodes" (pNode Node { _node_id = optional "id"
151 , _node_typename = required "typename"
152 , _node_userId = required "user_id"
153 , _node_parentId = required "parent_id"
154 , _node_name = required "name"
155 , _node_date = optional "date"
156 , _node_hyperdata = required "hyperdata"
157 -- , node_titleAbstract = optional "title_abstract"
162 nodeTable' :: Table (Maybe (Column PGInt4)
165 ,Maybe (Column PGInt4)
167 ,Maybe (Column PGTimestamptz)
175 ,(Column PGTimestamptz)
179 nodeTable' = Table "nodes" (PP.p7 ( optional "id"
180 , required "typename"
182 , optional "parent_id"
185 , required "hyperdata"
190 queryNodeTable :: Query NodeRead
191 queryNodeTable = queryTable nodeTable
193 selectNode :: Column PGInt4 -> Query NodeRead
194 selectNode id = proc () -> do
195 row <- queryNodeTable -< ()
196 restrict -< _node_id row .== id
199 runGetNodes :: Query NodeRead -> Cmd [NodeAny]
200 runGetNodes q = mkCmd $ \conn -> runQuery conn q
202 ------------------------------------------------------------------------
203 selectRootUser :: UserId -> Query NodeRead
204 selectRootUser userId = proc () -> do
205 row <- queryNodeTable -< ()
206 restrict -< _node_userId row .== (pgInt4 userId)
207 restrict -< _node_typename row .== (pgInt4 $ nodeTypeId NodeUser)
210 getRoot :: UserId -> Cmd [Node HyperdataUser]
211 getRoot userId = mkCmd $ \conn -> runQuery conn (selectRootUser userId)
212 ------------------------------------------------------------------------
214 -- | order by publication date
215 -- Favorites (Bool), node_ngrams
216 selectNodesWith :: ParentId -> Maybe NodeType
217 -> Maybe Offset -> Maybe Limit -> Query NodeRead
218 selectNodesWith parentId maybeNodeType maybeOffset maybeLimit =
219 --offset' maybeOffset $ limit' maybeLimit $ orderBy (asc (hyperdataDocument_Publication_date . node_hyperdata)) $ selectNodesWith' parentId typeId
220 limit' maybeLimit $ offset' maybeOffset $ orderBy (asc _node_id) $ selectNodesWith' parentId maybeNodeType
222 selectNodesWith' :: ParentId -> Maybe NodeType -> Query NodeRead
223 selectNodesWith' parentId maybeNodeType = proc () -> do
224 node <- (proc () -> do
225 row@(Node _ typeId _ parentId' _ _ _) <- queryNodeTable -< ()
226 restrict -< parentId' .== (toNullable $ pgInt4 parentId)
228 let typeId' = maybe 0 nodeTypeId maybeNodeType
230 restrict -< if typeId' > 0
231 then typeId .== (pgInt4 (typeId' :: Int))
233 returnA -< row ) -< ()
237 --type Cmd' a = forall m. (MonadReader env m, HasConnection env, MonadIO m) => m a
240 -- deleteNode :: (MonadReader Connection m, MonadIO m) => Int -> m Int
241 -- deleteNode :: Int -> Cmd' Int
243 deleteNode :: Int -> Cmd Int
244 deleteNode n = mkCmd $ \conn ->
245 fromIntegral <$> runDelete conn nodeTable
246 (\(Node n_id _ _ _ _ _ _) -> n_id .== pgInt4 n)
248 deleteNodes :: [Int] -> Cmd Int
249 deleteNodes ns = mkCmd $ \conn ->
250 fromIntegral <$> runDelete conn nodeTable
251 (\(Node n_id _ _ _ _ _ _) -> in_ ((map pgInt4 ns)) n_id)
254 getNodesWith :: JSONB a => Connection -> Int -> proxy a -> Maybe NodeType
255 -> Maybe Offset -> Maybe Limit -> IO [Node a]
256 getNodesWith conn parentId _ nodeType maybeOffset maybeLimit =
257 runQuery conn $ selectNodesWith
258 parentId nodeType maybeOffset maybeLimit
262 getNodesWithParentId :: Int
263 -> Maybe Text -> Connection -> IO [NodeAny]
264 getNodesWithParentId n _ conn = runQuery conn $ selectNodesWithParentID n
266 getNodesWithParentId' :: Int
267 -> Maybe Text -> Connection -> IO [NodeAny]
268 getNodesWithParentId' n _ conn = runQuery conn $ selectNodesWithParentID n
271 ------------------------------------------------------------------------
272 getDocumentsV3WithParentId :: Connection -> Int -> IO [Node HyperdataDocumentV3]
273 getDocumentsV3WithParentId conn n = runQuery conn $ selectNodesWith' n (Just NodeDocument)
275 getDocumentsWithParentId :: Connection -> Int -> IO [Node HyperdataDocument]
276 getDocumentsWithParentId conn n = runQuery conn $ selectNodesWith' n (Just NodeDocument)
278 ------------------------------------------------------------------------
281 selectNodesWithParentID :: Int -> Query NodeRead
282 selectNodesWithParentID n = proc () -> do
283 row@(Node _ _ _ parent_id _ _ _) <- queryNodeTable -< ()
286 parent_id .== (toNullable $ pgInt4 n)
292 selectNodesWithType :: Column PGInt4 -> Query NodeRead
293 selectNodesWithType type_id = proc () -> do
294 row@(Node _ tn _ _ _ _ _) <- queryNodeTable -< ()
295 restrict -< tn .== type_id
298 type JSONB = QueryRunnerColumnDefault PGJsonb
300 getNode :: JSONB a => Connection -> Int -> proxy a -> IO (Node a)
301 getNode conn id _ = do
302 fromMaybe (error $ "Node does node exist: " <> show id) . headMay <$> runQuery conn (limit 1 $ selectNode (pgInt4 id))
305 getNodesWithType :: Connection -> Column PGInt4 -> IO [Node HyperdataDocument]
306 getNodesWithType conn type_id = do
307 runQuery conn $ selectNodesWithType type_id
310 ------------------------------------------------------------------------
312 -- TODO Classe HasDefault where
313 -- default NodeType = Hyperdata
314 ------------------------------------------------------------------------
315 type NodeWrite' = NodePoly (Maybe Int) Int Int (Maybe ParentId) Text (Maybe UTCTime) ByteString
316 ------------------------------------------------------------------------
317 defaultUser :: HyperdataUser
318 defaultUser = HyperdataUser (Just $ (pack . show) EN)
320 nodeUserW :: Maybe Name -> Maybe HyperdataUser -> UserId -> NodeWrite'
321 nodeUserW maybeName maybeHyperdata = node NodeUser name user Nothing
323 name = maybe "User" identity maybeName
324 user = maybe defaultUser identity maybeHyperdata
325 ------------------------------------------------------------------------
326 defaultFolder :: HyperdataFolder
327 defaultFolder = HyperdataFolder (Just "Markdown Description")
329 nodeFolderW :: Maybe Name -> Maybe HyperdataFolder -> ParentId -> UserId -> NodeWrite'
330 nodeFolderW maybeName maybeFolder pid = node NodeFolder name folder (Just pid)
332 name = maybe "Folder" identity maybeName
333 folder = maybe defaultFolder identity maybeFolder
334 ------------------------------------------------------------------------
335 nodeCorpusW :: Maybe Name -> Maybe HyperdataCorpus -> ParentId -> UserId -> NodeWrite'
336 nodeCorpusW maybeName maybeCorpus pId = node NodeCorpus name corpus (Just pId)
338 name = maybe "Corpus" identity maybeName
339 corpus = maybe defaultCorpus identity maybeCorpus
340 --------------------------
341 defaultDocument :: HyperdataDocument
342 defaultDocument = hyperdataDocument
344 nodeDocumentW :: Maybe Name -> Maybe HyperdataDocument -> CorpusId -> UserId -> NodeWrite'
345 nodeDocumentW maybeName maybeDocument cId = node NodeDocument name doc (Just cId)
347 name = maybe "Document" identity maybeName
348 doc = maybe defaultDocument identity maybeDocument
349 ------------------------------------------------------------------------
350 defaultAnnuaire :: HyperdataAnnuaire
351 defaultAnnuaire = HyperdataAnnuaire (Just "Title") (Just "Description")
353 nodeAnnuaireW :: Maybe Name -> Maybe HyperdataAnnuaire -> ParentId -> UserId -> NodeWrite'
354 nodeAnnuaireW maybeName maybeAnnuaire pId = node NodeAnnuaire name annuaire (Just pId)
356 name = maybe "Annuaire" identity maybeName
357 annuaire = maybe defaultAnnuaire identity maybeAnnuaire
358 --------------------------
359 defaultContact :: HyperdataContact
360 defaultContact = HyperdataContact (Just "Name") (Just "email@here")
362 nodeContactW :: Maybe Name -> Maybe HyperdataContact -> AnnuaireId -> UserId -> NodeWrite'
363 nodeContactW maybeName maybeContact aId = node NodeContact name contact (Just aId)
365 name = maybe "Contact" identity maybeName
366 contact = maybe defaultContact identity maybeContact
367 ------------------------------------------------------------------------
368 defaultList :: HyperdataList
369 defaultList = HyperdataList (Just "Preferences")
371 nodeListW :: Maybe Name -> Maybe HyperdataList -> ParentId -> UserId -> NodeWrite'
372 nodeListW maybeName maybeList pId = node NodeList name list (Just pId)
374 name = maybe "Listes" identity maybeName
375 list = maybe defaultList identity maybeList
377 ------------------------------------------------------------------------
378 node :: (ToJSON a, Hyperdata a) => NodeType -> Name -> a -> Maybe ParentId -> UserId -> NodeWrite'
379 node nodeType name hyperData parentId userId = Node Nothing typeId userId parentId name Nothing byteData
381 typeId = nodeTypeId nodeType
382 byteData = DB.pack . DBL.unpack $ encode hyperData
384 -------------------------------
385 node2row :: (Functor maybe1, Functor maybe2, Functor maybe3) =>
386 NodePoly (maybe2 Int) Int Int (maybe1 Int)
387 Text (maybe3 UTCTime) ByteString
388 -> (maybe2 (Column PGInt4), Column PGInt4, Column PGInt4, maybe1 (Column PGInt4)
389 , Column PGText, maybe3 (Column PGTimestamptz), Column PGJsonb)
390 node2row (Node id tn ud pid nm dt hp) = ((pgInt4 <$> id)
398 ------------------------------------------------------------------------
399 insertNodesR' :: [NodeWrite'] -> Cmd [Int]
400 insertNodesR' ns = mkCmd $ \c -> insertNodesR ns c
402 insertNodes :: [NodeWrite'] -> Connection -> IO Int64
403 insertNodes ns conn = runInsertMany conn nodeTable' (map node2row ns)
405 insertNodesR :: [NodeWrite'] -> Connection -> IO [Int]
406 insertNodesR ns conn = runInsertManyReturning conn nodeTable' (map node2row ns) (\(i,_,_,_,_,_,_) -> i)
407 -------------------------
408 insertNodesWithParent :: Maybe ParentId -> [NodeWrite'] -> Connection -> IO Int64
409 insertNodesWithParent pid ns conn = insertNodes (map (set node_parentId pid) ns) conn
411 insertNodesWithParentR :: Maybe ParentId -> [NodeWrite'] -> Connection -> IO [Int]
412 insertNodesWithParentR pid ns conn = insertNodesR (map (set node_parentId pid) ns) conn
413 ------------------------------------------------------------------------
414 -- TODO Hierachy of Nodes
415 -- post and get same types Node' and update if changes
417 {- TODO semantic to achieve
418 post c uid pid [ Node' NodeCorpus "name" "{}" []
419 , Node' NodeFolder "name" "{}" [Node' NodeCorpus "test 2" "" [ Node' NodeDocument "title" "metaData" []
420 , Node' NodeDocument "title" "jsonData" []
425 ------------------------------------------------------------------------
428 -- currently this function remove the child relation
429 -- needs a Temporary type between Node' and NodeWriteT
430 node2table :: UserId -> Maybe ParentId -> Node' -> NodeWriteT
431 node2table uid pid (Node' nt txt v []) = ( Nothing, (pgInt4$ nodeTypeId nt), (pgInt4 uid), (fmap pgInt4 pid)
432 , pgStrictText txt, Nothing, pgStrictJSONB $ DB.pack $ DBL.unpack $ encode v)
433 node2table _ _ (Node' _ _ _ _) = panic "node2table: should not happen, Tree insert not implemented yet"
436 data Node' = Node' { _n_type :: NodeType
439 , _n_children :: [Node']
443 type NodeWriteT = ( Maybe (Column PGInt4)
446 , Maybe (Column PGInt4)
448 , Maybe (Column PGTimestamptz)
453 mkNode' :: [NodeWriteT] -> Cmd Int64
454 mkNode' ns = mkCmd $ \conn -> runInsertMany conn nodeTable' ns
456 mkNodeR' :: [NodeWriteT] -> Cmd [Int]
457 mkNodeR' ns = mkCmd $ \conn -> runInsertManyReturning conn nodeTable' ns (\(i,_,_,_,_,_,_) -> i)
460 ------------------------------------------------------------------------
462 data NewNode = NewNode { _newNodeId :: Int
463 , _newNodeChildren :: [Int] }
466 postNode :: UserId -> Maybe ParentId -> Node' -> Cmd NewNode
467 postNode uid pid (Node' nt txt v []) = do
468 pids <- mkNodeR' [node2table uid pid (Node' nt txt v [])]
470 [pid] -> pure $ NewNode pid []
471 _ -> panic "postNode: only one pid expected"
473 postNode uid pid (Node' NodeCorpus txt v ns) = do
474 NewNode pid' _ <- postNode uid pid (Node' NodeCorpus txt v [])
475 pids <- mkNodeR' (concat $ map (\n -> [childWith uid pid' n]) ns)
476 pure $ NewNode pid' pids
478 postNode uid pid (Node' NodeAnnuaire txt v ns) = do
479 NewNode pid' _ <- postNode uid pid (Node' NodeAnnuaire txt v [])
480 pids <- mkNodeR' (concat $ map (\n -> [childWith uid pid' n]) ns)
481 pure $ NewNode pid' pids
482 postNode _ _ (Node' _ _ _ _) = panic "TODO: postNode for this type not implemented yet"
485 childWith :: UserId -> ParentId -> Node' -> NodeWriteT
486 childWith uId pId (Node' NodeDocument txt v []) = node2table uId (Just pId) (Node' NodeDocument txt v [])
487 childWith uId pId (Node' NodeContact txt v []) = node2table uId (Just pId) (Node' NodeContact txt v [])
488 childWith _ _ (Node' _ _ _ _) = panic "This NodeType can not be a child"
491 -- TODO: remove hardcoded userId (with Reader)
492 -- TODO: user Reader in the API and adapt this function
496 mk :: Connection -> NodeType -> Maybe ParentId -> Text -> IO [Int]
497 mk c nt pId name = mk' c nt userId pId name
499 mk' :: Connection -> NodeType -> UserId -> Maybe ParentId -> Text -> IO [Int]
500 mk' c nt uId pId name = map fromIntegral <$> insertNodesWithParentR pId [node nt name hd pId uId] c
502 hd = HyperdataUser . Just . pack $ show EN
506 mk'' :: NodeType -> Maybe ParentId -> UserId -> Name -> Cmd [Int]
507 mk'' NodeUser Nothing uId name = mkCmd $ \c -> mk' c NodeUser uId Nothing name
508 mk'' NodeUser _ _ _ = panic "NodeUser do not have any parent"
509 mk'' _ Nothing _ _ = panic "NodeType does have a parent"
510 mk'' nt pId uId name = mkCmd $ \c -> mk' c nt uId pId name
512 mkRoot :: UserId -> Cmd [Int]
513 mkRoot uId = case uId > 0 of
514 False -> panic "UserId <= 0"
515 True -> mk'' NodeUser Nothing uId ("User Node : " <> (pack . show) uId)
517 mkCorpus :: Maybe Name -> Maybe HyperdataCorpus -> ParentId -> UserId -> Cmd [Int]
518 mkCorpus n h p u = insertNodesR' [nodeCorpusW n h p u]
520 mkList :: ParentId -> UserId -> Cmd [Int]
521 mkList p u = insertNodesR' [nodeListW Nothing Nothing p u]