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 FlexibleInstances #-}
17 {-# LANGUAGE FunctionalDependencies #-}
18 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
19 {-# LANGUAGE OverloadedStrings #-}
20 {-# LANGUAGE MultiParamTypeClasses #-}
21 {-# LANGUAGE NoImplicitPrelude #-}
22 {-# LANGUAGE TemplateHaskell #-}
24 module Gargantext.Database.Node where
27 import GHC.Int (Int64)
29 import Data.Time (UTCTime)
30 import Database.PostgreSQL.Simple.FromField ( Conversion
31 , ResultError(ConversionFailed)
36 import Prelude hiding (null, id, map, sum)
38 import Gargantext.Core.Types
39 import Gargantext.Database.Types.Node (NodeType)
40 import Gargantext.Database.Queries
41 import Gargantext.Database.Config (nodeTypeId)
42 import Gargantext.Prelude hiding (sum)
45 import Database.PostgreSQL.Simple.Internal (Field)
46 import Control.Applicative (Applicative)
47 import Control.Arrow (returnA)
48 import Control.Lens.TH (makeLensesWith, abbreviatedFields)
49 import Control.Monad.IO.Class
50 import Control.Monad.Reader
52 import Data.Maybe (Maybe, fromMaybe)
53 import Data.Text (Text)
54 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
55 import Data.Typeable (Typeable)
57 import qualified Data.ByteString as DB
58 import qualified Data.ByteString.Lazy as DBL
59 import Data.ByteString (ByteString)
61 import Database.PostgreSQL.Simple (Connection)
62 import Opaleye hiding (FromField)
63 import Opaleye.Internal.QueryArr (Query)
64 import qualified Data.Profunctor.Product as PP
65 -- | Types for Node Database Management
68 newtype Cmd a = Cmd (ReaderT Connection IO a)
69 deriving (Functor, Applicative, Monad, MonadReader Connection, MonadIO)
71 runCmd :: Connection -> Cmd a -> IO a
72 runCmd c (Cmd f) = runReaderT f c
74 mkCmd :: (Connection -> IO a) -> Cmd a
78 newtype Cmd a = Cmd { unCmd :: Connection -> IO a }
80 instance Monad Cmd where
81 return a = Cmd $ \_ -> return a
83 m >>= f = Cmd $ \c -> do
88 ------------------------------------------------------------------------
90 ------------------------------------------------------------------------
92 instance FromField HyperdataCorpus where
93 fromField = fromField'
95 instance FromField HyperdataDocument where
96 fromField = fromField'
98 instance FromField HyperdataDocumentV3 where
99 fromField = fromField'
101 instance FromField HyperdataProject where
102 fromField = fromField'
104 instance FromField HyperdataUser where
105 fromField = fromField'
108 instance QueryRunnerColumnDefault PGJsonb HyperdataDocument where
109 queryRunnerColumnDefault = fieldQueryRunnerColumn
110 instance QueryRunnerColumnDefault PGJsonb HyperdataDocumentV3 where
111 queryRunnerColumnDefault = fieldQueryRunnerColumn
113 instance QueryRunnerColumnDefault PGJsonb HyperdataCorpus where
114 queryRunnerColumnDefault = fieldQueryRunnerColumn
116 instance QueryRunnerColumnDefault PGJsonb HyperdataProject where
117 queryRunnerColumnDefault = fieldQueryRunnerColumn
119 instance QueryRunnerColumnDefault PGJsonb HyperdataUser where
120 queryRunnerColumnDefault = fieldQueryRunnerColumn
124 fromField' :: (Typeable b, FromJSON b) => Field -> Maybe DB.ByteString -> Conversion b
125 fromField' field mb = do
126 v <- fromField field mb
129 valueToHyperdata v = case fromJSON v of
131 Error _err -> returnError ConversionFailed field "cannot parse hyperdata"
134 $(makeAdaptorAndInstance "pNode" ''NodePoly)
135 $(makeLensesWith abbreviatedFields ''NodePoly)
138 nodeTable :: Table NodeWrite NodeRead
139 nodeTable = Table "nodes" (pNode Node { node_id = optional "id"
140 , node_typename = required "typename"
141 , node_userId = required "user_id"
142 , node_parentId = required "parent_id"
143 , node_name = required "name"
144 , node_date = optional "date"
145 , node_hyperdata = required "hyperdata"
146 -- , node_titleAbstract = optional "title_abstract"
151 nodeTable' :: Table (Maybe (Column PGInt4)
156 ,Maybe (Column PGTimestamptz)
164 ,(Column PGTimestamptz)
168 nodeTable' = Table "nodes" (PP.p7 ( optional "id"
169 , required "typename"
171 , required "parent_id"
174 , required "hyperdata"
179 queryNodeTable :: Query NodeRead
180 queryNodeTable = queryTable nodeTable
183 selectNode :: Column PGInt4 -> Query NodeRead
184 selectNode id = proc () -> do
185 row <- queryNodeTable -< ()
186 restrict -< node_id row .== id
189 runGetNodes :: Query NodeRead -> Cmd [Node Value]
190 runGetNodes q = mkCmd $ \conn -> runQuery conn q
192 -- | order by publication date
193 -- Favorites (Bool), node_ngrams
194 selectNodesWith :: ParentId -> Maybe NodeType
195 -> Maybe Offset -> Maybe Limit -> Query NodeRead
196 selectNodesWith parentId maybeNodeType maybeOffset maybeLimit =
197 --offset' maybeOffset $ limit' maybeLimit $ orderBy (asc (hyperdataDocument_Publication_date . node_hyperdata)) $ selectNodesWith' parentId typeId
198 limit' maybeLimit $ offset' maybeOffset $ orderBy (asc node_id) $ selectNodesWith' parentId maybeNodeType
200 selectNodesWith' :: ParentId -> Maybe NodeType -> Query NodeRead
201 selectNodesWith' parentId maybeNodeType = proc () -> do
202 node <- (proc () -> do
203 row@(Node _ typeId _ parentId' _ _ _) <- queryNodeTable -< ()
204 restrict -< parentId' .== (toNullable $ pgInt4 parentId)
206 let typeId' = maybe 0 nodeTypeId maybeNodeType
208 restrict -< if typeId' > 0
209 then typeId .== (pgInt4 (typeId' :: Int))
211 returnA -< row ) -< ()
215 --type Cmd' a = forall m. (MonadReader env m, HasConnection env, MonadIO m) => m a
218 -- deleteNode :: (MonadReader Connection m, MonadIO m) => Int -> m Int
219 -- deleteNode :: Int -> Cmd' Int
221 deleteNode :: Int -> Cmd Int
222 deleteNode n = mkCmd $ \conn ->
223 fromIntegral <$> runDelete conn nodeTable
224 (\(Node n_id _ _ _ _ _ _) -> n_id .== pgInt4 n)
226 deleteNodes :: [Int] -> Cmd Int
227 deleteNodes ns = mkCmd $ \conn ->
228 fromIntegral <$> runDelete conn nodeTable
229 (\(Node n_id _ _ _ _ _ _) -> in_ ((map pgInt4 ns)) n_id)
232 getNodesWith :: Connection -> Int -> Maybe NodeType
233 -> Maybe Offset -> Maybe Limit -> IO [Node Value]
234 getNodesWith conn parentId nodeType maybeOffset maybeLimit =
235 runQuery conn $ selectNodesWith
236 parentId nodeType maybeOffset maybeLimit
240 getNodesWithParentId :: Int
241 -> Maybe Text -> Connection -> IO [Node Value]
242 getNodesWithParentId n _ conn = runQuery conn $ selectNodesWithParentID n
244 getNodesWithParentId' :: Int
245 -> Maybe Text -> Connection -> IO [Node Value]
246 getNodesWithParentId' n _ conn = runQuery conn $ selectNodesWithParentID n
249 ------------------------------------------------------------------------
250 getDocumentsV3WithParentId :: Connection -> Int -> IO [Node HyperdataDocumentV3]
251 getDocumentsV3WithParentId conn n = runQuery conn $ selectNodesWith' n (Just Document)
253 getDocumentsWithParentId :: Connection -> Int -> IO [Node HyperdataDocument]
254 getDocumentsWithParentId conn n = runQuery conn $ selectNodesWith' n (Just Document)
256 ------------------------------------------------------------------------
259 selectNodesWithParentID :: Int -> Query NodeRead
260 selectNodesWithParentID n = proc () -> do
261 row@(Node _ _ _ parent_id _ _ _) <- queryNodeTable -< ()
264 parent_id .== (toNullable $ pgInt4 n)
270 selectNodesWithType :: Column PGInt4 -> Query NodeRead
271 selectNodesWithType type_id = proc () -> do
272 row@(Node _ tn _ _ _ _ _) <- queryNodeTable -< ()
273 restrict -< tn .== type_id
277 getNode :: Connection -> Int -> IO (Node Value)
279 fromMaybe (error $ "Node does node exist: " <> show id) . headMay <$> runQuery conn (limit 1 $ selectNode (pgInt4 id))
282 getNodesWithType :: Connection -> Column PGInt4 -> IO [Node HyperdataDocument]
283 getNodesWithType conn type_id = do
284 runQuery conn $ selectNodesWithType type_id
290 ------------------------------------------------------------------------
292 ------------------------------------------------------------------------
293 type NodeWrite' = NodePoly (Maybe Int) Int Int (ParentId) Text (Maybe UTCTime) ByteString
295 --node :: UserId -> ParentId -> NodeType -> Text -> Value -> NodeWrite'
296 node :: UserId -> ParentId -> NodeType -> Text -> Value -> NodeWrite'
297 node userId parentId nodeType name nodeData = Node Nothing typeId userId parentId name Nothing byteData
299 typeId = nodeTypeId nodeType
300 byteData = DB.pack $ DBL.unpack $ encode nodeData
304 node2write :: (Functor f2, Functor f1) =>
306 -> NodePoly (f1 Int) Int Int parentId Text (f2 UTCTime) ByteString
307 -> (f1 (Column PGInt4), Column PGInt4, Column PGInt4,
308 Column PGInt4, Column PGText, f2 (Column PGTimestamptz),
310 node2write pid (Node id tn ud _ nm dt hp) = ((pgInt4 <$> id)
320 mkNode :: ParentId -> [NodeWrite'] -> Connection -> IO Int64
321 mkNode pid ns conn = runInsertMany conn nodeTable' $ map (node2write pid) ns
323 mkNodeR :: ParentId -> [NodeWrite'] -> Connection -> IO [Int]
324 mkNodeR pid ns conn = runInsertManyReturning conn nodeTable' (map (node2write pid) ns) (\(i,_,_,_,_,_,_) -> i)
327 ------------------------------------------------------------------------
328 -- TODO Hierachy of Nodes
329 -- post and get same types Node' and update if changes
331 {- TODO semantic to achieve
332 post c uid pid [ Node' Corpus "name" "{}" []
333 , Node' Folder "name" "{}" [Node' Corpus "test 2" "" [ Node' Document "title" "metaData" []
334 , Node' Document "title" "jsonData" []
339 ------------------------------------------------------------------------
342 -- currently this function remove the child relation
343 -- needs a Temporary type between Node' and NodeWriteT
344 node2table :: UserId -> ParentId -> Node' -> NodeWriteT
345 node2table uid pid (Node' nt txt v []) = ( Nothing, (pgInt4$ nodeTypeId nt), (pgInt4 uid), (pgInt4 pid)
346 , pgStrictText txt, Nothing, pgStrictJSONB $ DB.pack $ DBL.unpack $ encode v)
347 node2table _ _ (Node' _ _ _ _) = panic "node2table: should not happen, Tree insert not implemented yet"
350 data Node' = Node' { _n_type :: NodeType
353 , _n_children :: [Node']
357 type NodeWriteT = ( Maybe (Column PGInt4)
358 , Column PGInt4, Column PGInt4
359 , Column PGInt4, Column PGText
360 , Maybe (Column PGTimestamptz)
365 mkNode' :: [NodeWriteT] -> Cmd Int64
366 mkNode' ns = mkCmd $ \conn -> runInsertMany conn nodeTable' ns
368 mkNodeR' :: [NodeWriteT] -> Cmd [Int]
369 mkNodeR' ns = mkCmd $ \conn -> runInsertManyReturning conn nodeTable' ns (\(i,_,_,_,_,_,_) -> i)
371 data NewNode = NewNode { _newNodeId :: Int
372 , _newNodeChildren :: [Int] }
375 postNode :: UserId -> ParentId -> Node' -> Cmd NewNode
376 postNode uid pid (Node' nt txt v []) = do
377 pids <- mkNodeR' [node2table uid pid (Node' nt txt v [])]
379 [pid] -> pure $ NewNode pid []
380 _ -> panic "postNode: only one pid expected"
382 postNode uid pid (Node' NodeCorpus txt v ns) = do
383 NewNode pid' _ <- postNode uid pid (Node' NodeCorpus txt v [])
384 pids <- mkNodeR' (concat $ map (\n -> [childWith uid pid' n]) ns)
385 pure $ NewNode pid' pids
387 postNode uid pid (Node' Annuaire txt v ns) = do
388 NewNode pid' _ <- postNode uid pid (Node' Annuaire txt v [])
389 pids <- mkNodeR' (concat $ map (\n -> [childWith uid pid' n]) ns)
390 pure $ NewNode pid' pids
391 postNode _ _ (Node' _ _ _ _) = panic "TODO: postNode for this type not implemented yet"
394 childWith :: UserId -> ParentId -> Node' -> NodeWriteT
395 childWith uId pId (Node' Document txt v []) = node2table uId pId (Node' Document txt v [])
396 childWith uId pId (Node' UserPage txt v []) = node2table uId pId (Node' UserPage txt v [])
397 childWith _ _ (Node' _ _ _ _) = panic "This NodeType can not be a child"