Node.hs 14.5 KB
Newer Older
1
{-|
2
import Gargantext.Database.Prelude (Cmd, runPGSQuery)
3
Module      : Gargantext.Database.Query.Table.Node
4 5 6 7 8 9 10 11
Description : Main Tools of Node to the database
Copyright   : (c) CNRS, 2017-Present
License     : AGPL + CECILL v3
Maintainer  : team@gargantext.org
Stability   : experimental
Portability : POSIX
-}

12

13 14 15 16 17
{-# OPTIONS_GHC -fno-warn-orphans        #-}

{-# LANGUAGE Arrows                 #-}
{-# LANGUAGE ConstraintKinds        #-}
{-# LANGUAGE FunctionalDependencies #-}
18
{-# LANGUAGE QuasiQuotes       #-}
19 20 21
{-# LANGUAGE TemplateHaskell        #-}
{-# LANGUAGE TypeFamilies           #-}

22
module Gargantext.Database.Query.Table.Node
23
  where
24 25 26 27

import Control.Arrow (returnA)
import Control.Lens (set, view)
import Data.Aeson
28
import Data.Maybe (fromMaybe)
29
import Data.Text (Text)
30 31 32 33 34
import qualified Database.PostgreSQL.Simple as DPS
import Database.PostgreSQL.Simple.SqlQQ (sql)
import Opaleye hiding (FromField)
import Prelude hiding (null, id, map, sum)

Alexandre Delanoë's avatar
Alexandre Delanoë committed
35
import Gargantext.Core
36
import Gargantext.Core.Types
37
import Gargantext.Database.Admin.Types.Hyperdata
38
import Gargantext.Database.Admin.Types.Hyperdata.Default
39
import Gargantext.Database.Prelude
40 41
import Gargantext.Database.Query.Filter (limit', offset')
import Gargantext.Database.Query.Table.Node.Error
42 43 44 45 46
import Gargantext.Database.Schema.Node
import Gargantext.Prelude hiding (sum, head)


queryNodeSearchTable :: Query NodeSearchRead
47
queryNodeSearchTable = selectTable nodeTableSearch
48 49

selectNode :: Column PGInt4 -> Query NodeRead
50
selectNode id' = proc () -> do
51
    row      <- queryNodeTable -< ()
52
    restrict -< _node_id row .== id'
53
    returnA  -< row
54 55 56 57 58 59 60 61

runGetNodes :: Query NodeRead -> Cmd err [Node HyperdataAny]
runGetNodes = runOpaQuery

------------------------------------------------------------------------
------------------------------------------------------------------------
-- | order by publication date
-- Favorites (Bool), node_ngrams
62 63
selectNodesWith :: HasDBid NodeType
                => ParentId     -> Maybe NodeType
64
                -> Maybe Offset -> Maybe Limit   -> Query NodeRead
65
selectNodesWith parentId maybeNodeType maybeOffset maybeLimit =
66 67 68 69 70
        --offset' maybeOffset $ limit' maybeLimit $ orderBy (asc (hyperdataDocument_Publication_date . node_hyperdata)) $ selectNodesWith' parentId typeId
  limit' maybeLimit $ offset' maybeOffset
                    $ orderBy (asc _node_id)
                    $ selectNodesWith' parentId maybeNodeType

71 72
selectNodesWith' :: HasDBid NodeType
                 => ParentId -> Maybe NodeType -> Query NodeRead
73
selectNodesWith' parentId maybeNodeType = proc () -> do
74
    node' <- (proc () -> do
75
      row@(Node _ _ typeId _ parentId' _ _ _) <- queryNodeTable -< ()
76 77
      restrict -< parentId' .== (pgNodeId parentId)

78
      let typeId' = maybe 0 toDBid maybeNodeType
79 80

      restrict -< if typeId' > 0
81
                     then typeId   .== (sqlInt4 (typeId' :: Int))
82 83
                     else (pgBool True)
      returnA  -< row ) -< ()
84
    returnA -< node'
85 86 87

deleteNode :: NodeId -> Cmd err Int
deleteNode n = mkCmd $ \conn ->
88 89 90 91 92
  fromIntegral <$> runDelete_ conn
                 (Delete nodeTable
                         (\(Node n_id _ _ _ _ _ _ _) -> n_id .== pgNodeId n)
                         rCount
                 )
93 94 95

deleteNodes :: [NodeId] -> Cmd err Int
deleteNodes ns = mkCmd $ \conn ->
96 97 98 99 100
  fromIntegral <$> runDelete_ conn
                   (Delete nodeTable
                           (\(Node n_id _ _ _ _ _ _ _) -> in_ ((map pgNodeId ns)) n_id)
                           rCount
                   )
101 102

-- TODO: NodeType should match with `a'
103
getNodesWith :: (JSONB a, HasDBid NodeType) => NodeId -> proxy a -> Maybe NodeType
104 105 106 107 108 109
             -> Maybe Offset -> Maybe Limit -> Cmd err [Node a]
getNodesWith parentId _ nodeType maybeOffset maybeLimit =
    runOpaQuery $ selectNodesWith parentId nodeType maybeOffset maybeLimit

-- TODO: Why is the second parameter ignored?
-- TODO: Why not use getNodesWith?
110
getNodesWithParentId :: (Hyperdata a, JSONB a)
111 112 113 114 115 116 117 118
                     => Maybe NodeId
                     -> Cmd err [Node a]
getNodesWithParentId n = runOpaQuery $ selectNodesWithParentID n'
  where
    n' = case n of
      Just n'' -> n''
      Nothing  -> 0

119 120 121 122

-- | Given a node id, find it's closest parent of given type
-- NOTE: This isn't too optimal: can make successive queries depending on how
-- deeply nested the child is.
123 124
getClosestParentIdByType :: HasDBid NodeType
                         => NodeId
125 126 127 128 129
                         -> NodeType
                         -> Cmd err (Maybe NodeId)
getClosestParentIdByType nId nType = do
  result <- runPGSQuery query (nId, 0 :: Int)
  case result of
130
    [(NodeId parentId, pTypename)] -> do
131
      if toDBid nType == pTypename then
132 133 134 135 136 137 138 139
        pure $ Just $ NodeId parentId
      else
        getClosestParentIdByType (NodeId parentId) nType
    _ -> pure Nothing
  where
    query :: DPS.Query
    query = [sql|
      SELECT n2.id, n2.typename
140
      FROM nodes n1
141 142 143 144
        JOIN nodes n2 ON n1.parent_id = n2.id
        WHERE n1.id = ? AND 0 = ?;
    |]

145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167
-- | Similar to `getClosestParentIdByType` but includes current node
-- in search too
getClosestParentIdByType' :: HasDBid NodeType
                          => NodeId
                          -> NodeType
                          -> Cmd err (Maybe NodeId)
getClosestParentIdByType' nId nType = do
  result <- runPGSQuery query (nId, 0 :: Int)
  case result of
    [(NodeId id, pTypename)] -> do
      if toDBid nType == pTypename then
        pure $ Just $ NodeId id
      else
        getClosestParentIdByType nId nType
    _ -> pure Nothing
  where
    query :: DPS.Query
    query = [sql|
      SELECT n.id, n.typename
      FROM nodes n
      WHERE n.id = ? AND 0 = ?;
    |]

168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185
-- | Given a node id, find all it's children (no matter how deep) of
-- given node type.
getChildrenByType :: HasDBid NodeType
                  => NodeId
                  -> NodeType
                  -> Cmd err [NodeId]
getChildrenByType nId nType = do
  result <- runPGSQuery query (nId, 0 :: Int)
  children_lst <- mapM (\(id, _) -> getChildrenByType id nType) result
  pure $ concat $ [fst <$> filter (\(_, pTypename) -> pTypename == toDBid nType) result] ++ children_lst
  where
    query :: DPS.Query
    query = [sql|
      SELECT n.id, n.typename
      FROM nodes n
        WHERE n.parent_id = ? AND 0 = ?;
    |]

186
------------------------------------------------------------------------
187
getDocumentsV3WithParentId :: HasDBid NodeType => NodeId -> Cmd err [Node HyperdataDocumentV3]
188 189 190
getDocumentsV3WithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeDocument)

-- TODO: merge with getDocumentsWithParentId by having a class IsHyperdataDocument
191
getDocumentsWithParentId :: HasDBid NodeType => NodeId -> Cmd err [Node HyperdataDocument]
192 193
getDocumentsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeDocument)

194
getListsModelWithParentId :: HasDBid NodeType => NodeId -> Cmd err [Node HyperdataModel]
195
getListsModelWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeModel)
196

197
getCorporaWithParentId :: HasDBid NodeType => NodeId -> Cmd err [Node HyperdataCorpus]
198 199 200 201 202
getCorporaWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeCorpus)

------------------------------------------------------------------------
selectNodesWithParentID :: NodeId -> Query NodeRead
selectNodesWithParentID n = proc () -> do
203
    row@(Node _ _ _ _ parent_id _ _ _) <- queryNodeTable -< ()
204 205 206
    restrict -< parent_id .== (pgNodeId n)
    returnA -< row

207 208 209 210

------------------------------------------------------------------------
-- | Example of use:
-- runCmdReplEasy  (getNodesWithType NodeList (Proxy :: Proxy HyperdataList))
211
getNodesWithType :: (HasNodeError err, JSONB a, HasDBid NodeType) => NodeType -> proxy a -> Cmd err [Node a]
212
getNodesWithType nt _ = runOpaQuery $ selectNodesWithType nt
213
  where
214 215
    selectNodesWithType ::  HasDBid NodeType
                         => NodeType -> Query NodeRead
216
    selectNodesWithType nt' = proc () -> do
217
        row@(Node _ _ tn _ _ _ _ _) <- queryNodeTable -< ()
218
        restrict -< tn .== (sqlInt4 $ toDBid nt')
219 220
        returnA -< row

221
getNodesIdWithType :: (HasNodeError err, HasDBid NodeType) => NodeType -> Cmd err [NodeId]
222 223 224 225
getNodesIdWithType nt = do
  ns <- runOpaQuery $ selectNodesIdWithType nt
  pure (map NodeId ns)

226 227
selectNodesIdWithType :: HasDBid NodeType
                      => NodeType -> Query (Column PGInt4)
228
selectNodesIdWithType nt = proc () -> do
229
    row@(Node _ _ tn _ _ _ _ _) <- queryNodeTable -< ()
230
    restrict -< tn .== (sqlInt4 $ toDBid nt)
231
    returnA -< _node_id row
232

233
------------------------------------------------------------------------
234 235


236 237 238 239 240 241
getNode :: HasNodeError err => NodeId -> Cmd err (Node Value)
getNode nId = do
  maybeNode <- headMay <$> runOpaQuery (selectNode (pgNodeId nId))
  case maybeNode of
    Nothing -> nodeError (DoesNotExist nId)
    Just  r -> pure r
242

243 244
getNodeWith :: (HasNodeError err, JSONB a)
            => NodeId -> proxy a -> Cmd err (Node a)
245
getNodeWith nId _ = do
246 247 248 249
  maybeNode <- headMay <$> runOpaQuery (selectNode (pgNodeId nId))
  case maybeNode of
    Nothing -> nodeError (DoesNotExist nId)
    Just  r -> pure r
250

251

252
------------------------------------------------------------------------
253
-- | Sugar to insert Node with NodeType in Database
254 255
insertDefaultNode :: HasDBid NodeType
                  => NodeType -> ParentId -> UserId -> Cmd err [NodeId]
256
insertDefaultNode nt p u = insertNode nt Nothing Nothing p u
257

258 259
insertNode :: HasDBid NodeType
           => NodeType -> Maybe Name -> Maybe DefaultHyperdata -> ParentId -> UserId -> Cmd err [NodeId]
260
insertNode nt n h p u = insertNodesR [nodeW nt n h p u]
261

262 263
nodeW ::  HasDBid NodeType
       => NodeType -> Maybe Name -> Maybe DefaultHyperdata -> ParentId -> UserId -> NodeWrite
264
nodeW nt n h p u = node nt n' h' (Just p) u
265
  where
266 267
    n' = fromMaybe (defaultName nt) n
    h' = maybe     (defaultHyperdata nt) identity h
268

269
------------------------------------------------------------------------
270
node :: (ToJSON a, Hyperdata a, HasDBid NodeType)
271 272 273 274 275 276
     => NodeType
     -> Name
     -> a
     -> Maybe ParentId
     -> UserId
     -> NodeWrite
277
node nodeType name hyperData parentId userId =
278
  Node Nothing Nothing
279 280
       (sqlInt4 typeId)
       (sqlInt4 userId)
281
       (pgNodeId <$> parentId)
282
       (sqlStrictText name)
283 284 285
       Nothing
       (pgJSONB $ cs $ encode hyperData)
    where
286
      typeId = toDBid nodeType
287 288 289 290 291

                  -------------------------------
insertNodes :: [NodeWrite] -> Cmd err Int64
insertNodes ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeTable ns rCount Nothing

Alexandre Delanoë's avatar
Alexandre Delanoë committed
292 293
{-
insertNodes' :: [Node a] -> Cmd err Int64
294 295 296 297 298 299
insertNodes' ns = mkCmd $ \conn -> runInsert_ conn
                        $ Insert nodeTable ns' rCount Nothing
  where
    ns' :: [NodeWrite]
    ns' = map (\(Node i t u p n d h)
                -> Node (pgNodeId          <$> i)
300 301
                        (sqlInt4 $ toDBid      t)
                        (sqlInt4                u)
302
                        (pgNodeId          <$> p)
303
                        (sqlStrictText          n)
304 305 306
                        (pgUTCTime         <$> d)
                        (pgJSONB $ cs $ encode h)
              ) ns
Alexandre Delanoë's avatar
Alexandre Delanoë committed
307
-}
308

309 310
insertNodesR :: [NodeWrite] -> Cmd err [NodeId]
insertNodesR ns = mkCmd $ \conn ->
311
  runInsert_ conn (Insert nodeTable ns (rReturning (\(Node i _ _ _ _ _ _ _) -> i)) Nothing)
312 313

insertNodesWithParent :: Maybe ParentId -> [NodeWrite] -> Cmd err Int64
314
insertNodesWithParent pid ns = insertNodes (set node_parent_id (pgNodeId <$> pid) <$> ns)
315 316

insertNodesWithParentR :: Maybe ParentId -> [NodeWrite] -> Cmd err [NodeId]
317
insertNodesWithParentR pid ns = insertNodesR (set node_parent_id (pgNodeId <$> pid) <$> ns)
318 319 320 321
------------------------------------------------------------------------
-- TODO
-- currently this function removes the child relation
-- needs a Temporary type between Node' and NodeWriteT
322

323 324
node2table :: HasDBid NodeType
           => UserId -> Maybe ParentId -> Node' -> NodeWrite
325
node2table uid pid (Node' nt txt v []) = Node Nothing Nothing (sqlInt4 $ toDBid nt) (sqlInt4 uid) (fmap pgNodeId pid) (sqlStrictText txt) Nothing (pgStrictJSONB $ cs $ encode v)
326 327 328 329 330 331 332 333 334 335
node2table _ _ (Node' _ _ _ _) = panic "node2table: should not happen, Tree insert not implemented yet"


data Node' = Node' { _n_type :: NodeType
                   , _n_name :: Text
                   , _n_data :: Value
                   , _n_children :: [Node']
                   } deriving (Show)

mkNodes :: [NodeWrite] -> Cmd err Int64
336 337
mkNodes ns = mkCmd $ \conn -> runInsert_ conn
                   $ Insert nodeTable ns rCount Nothing
338 339 340 341 342

mkNodeR :: [NodeWrite] -> Cmd err [NodeId]
mkNodeR ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeTable ns (rReturning _node_id) Nothing

------------------------------------------------------------------------
343 344
childWith ::  HasDBid NodeType
           => UserId -> ParentId -> Node' -> NodeWrite
345 346 347 348 349 350 351 352 353 354 355 356 357
childWith uId pId (Node' NodeDocument txt v []) = node2table uId (Just pId) (Node' NodeDocument txt v [])
childWith uId pId (Node' NodeContact  txt v []) = node2table uId (Just pId) (Node' NodeContact txt v [])
childWith _   _   (Node' _        _   _ _) = panic "This NodeType can not be a child"


-- =================================================================== --
-- |
-- CorpusDocument is a corpus made from a set of documents
-- CorpusContact  is a corpus made from a set of contacts (syn of Annuaire)
data CorpusType = CorpusDocument | CorpusContact

class MkCorpus a
  where
358
    mk :: HasDBid NodeType => Maybe Name -> Maybe a -> ParentId -> UserId -> Cmd err [NodeId]
359 360 361

instance MkCorpus HyperdataCorpus
  where
362 363
    mk n Nothing  p u = insertNode NodeCorpus n Nothing p u
    mk n (Just h) p u = insertNode NodeCorpus n (Just $ DefaultCorpus h) p u
364 365 366 367


instance MkCorpus HyperdataAnnuaire
  where
368 369
    mk n Nothing  p u = insertNode NodeCorpus   n Nothing p u
    mk n (Just h) p u = insertNode NodeAnnuaire n (Just $ DefaultAnnuaire h) p u
370 371


372
getOrMkList :: (HasNodeError err, HasDBid NodeType)
373 374 375
            => ParentId
            -> UserId
            -> Cmd err ListId
376 377 378
getOrMkList pId uId =
  maybe (mkList' pId uId) (pure . view node_id) . headMay =<< getListsWithParentId pId
    where
379
      mkList' pId' uId' = maybe (nodeError MkNode) pure . headMay =<< insertDefaultNode NodeList pId' uId'
380

381
-- | TODO remove defaultList
382
defaultList :: (HasNodeError err, HasDBid NodeType) => CorpusId -> Cmd err ListId
383 384 385
defaultList cId =
  maybe (nodeError NoListFound) (pure . view node_id) . headMay =<< getListsWithParentId cId

386 387 388
defaultListMaybe :: (HasNodeError err, HasDBid NodeType) => CorpusId -> Cmd err (Maybe NodeId)
defaultListMaybe cId = headMay <$> map (view node_id ) <$> getListsWithParentId cId

389
getListsWithParentId :: HasDBid NodeType => NodeId -> Cmd err [Node HyperdataList]
390 391
getListsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeList)