src/Gargantext/Database/Query/Table/Node.hs

   1 {-|
   2 import Gargantext.Database.Prelude (Cmd, runPGSQuery)
   3 Module      : Gargantext.Database.Query.Table.Node
   4 Description : Main Tools of Node to the database
   5 Copyright   : (c) CNRS, 2017-Present
   6 License     : AGPL + CECILL v3
   7 Maintainer  : team@gargantext.org
   8 Stability   : experimental
   9 Portability : POSIX
  10 -}
  11
  12 {-# OPTIONS_GHC -fno-warn-orphans        #-}
  13
  14 {-# LANGUAGE Arrows                 #-}
  15 {-# LANGUAGE ConstraintKinds        #-}
  16 {-# LANGUAGE FunctionalDependencies #-}
  17 {-# LANGUAGE QuasiQuotes       #-}
  18 {-# LANGUAGE TemplateHaskell        #-}
  19 {-# LANGUAGE TypeFamilies           #-}
  20
  21 module Gargantext.Database.Query.Table.Node
  22   where
  23
  24 import Control.Arrow (returnA)
  25 import Control.Lens (set, view)
  26 import Data.Aeson
  27 import Data.Maybe (fromMaybe)
  28 import Data.Text (Text)
  29 import qualified Database.PostgreSQL.Simple as DPS
  30 import Database.PostgreSQL.Simple.SqlQQ (sql)
  31 import Opaleye hiding (FromField)
  32 import Prelude hiding (null, id, map, sum)
  33
  34 import Gargantext.Core
  35 import Gargantext.Core.Types
  36 import Gargantext.Database.Admin.Types.Hyperdata
  37 import Gargantext.Database.Admin.Types.Hyperdata.Default
  38 import Gargantext.Database.Prelude
  39 import Gargantext.Database.Query.Filter (limit', offset')
  40 import Gargantext.Database.Query.Table.Node.Error
  41 import Gargantext.Database.Schema.Node
  42 import Gargantext.Prelude hiding (sum, head)
  43
  44 queryNodeSearchTable :: Select NodeSearchRead
  45 queryNodeSearchTable = selectTable nodeTableSearch
  46
  47 selectNode :: Column SqlInt4 -> Select NodeRead
  48 selectNode id' = proc () -> do
  49     row      <- queryNodeTable -< ()
  50     restrict -< _node_id row .== id'
  51     returnA  -< row
  52
  53 runGetNodes :: Select NodeRead -> Cmd err [Node HyperdataAny]
  54 runGetNodes = runOpaQuery
  55
  56 ------------------------------------------------------------------------
  57 ------------------------------------------------------------------------
  58 -- | order by publication date
  59 -- Favorites (Bool), node_ngrams
  60 selectNodesWith :: HasDBid NodeType
  61                 => ParentId     -> Maybe NodeType
  62                 -> Maybe Offset -> Maybe Limit   -> Select NodeRead
  63 selectNodesWith parentId maybeNodeType maybeOffset maybeLimit =
  64         --offset' maybeOffset $ limit' maybeLimit $ orderBy (asc (hyperdataDocument_Publication_date . node_hyperdata)) $ selectNodesWith' parentId typeId
  65   limit' maybeLimit $ offset' maybeOffset
  66                     $ orderBy (asc _node_id)
  67                     $ selectNodesWith' parentId maybeNodeType
  68
  69 selectNodesWith' :: HasDBid NodeType
  70                  => ParentId -> Maybe NodeType -> Select NodeRead
  71 selectNodesWith' parentId maybeNodeType = proc () -> do
  72     node' <- (proc () -> do
  73       row@(Node _ _ typeId _ parentId' _ _ _) <- queryNodeTable -< ()
  74       restrict -< parentId' .== (pgNodeId parentId)
  75
  76       let typeId' = maybe 0 toDBid maybeNodeType
  77
  78       restrict -< if typeId' > 0
  79                      then typeId   .== (sqlInt4 (typeId' :: Int))
  80                      else (sqlBool True)
  81       returnA  -< row ) -< ()
  82     returnA -< node'
  83
  84 deleteNode :: NodeId -> Cmd err Int
  85 deleteNode n = mkCmd $ \conn ->
  86   fromIntegral <$> runDelete_ conn
  87                  (Delete nodeTable
  88                          (\(Node n_id _ _ _ _ _ _ _) -> n_id .== pgNodeId n)
  89                          rCount
  90                  )
  91
  92 deleteNodes :: [NodeId] -> Cmd err Int
  93 deleteNodes ns = mkCmd $ \conn ->
  94   fromIntegral <$> runDelete_ conn
  95                    (Delete nodeTable
  96                            (\(Node n_id _ _ _ _ _ _ _) -> in_ ((map pgNodeId ns)) n_id)
  97                            rCount
  98                    )
  99
 100 -- TODO: NodeType should match with `a'
 101 getNodesWith :: (JSONB a, HasDBid NodeType) => NodeId -> proxy a -> Maybe NodeType
 102              -> Maybe Offset -> Maybe Limit -> Cmd err [Node a]
 103 getNodesWith parentId _ nodeType maybeOffset maybeLimit =
 104     runOpaQuery $ selectNodesWith parentId nodeType maybeOffset maybeLimit
 105
 106 -- TODO: Why is the second parameter ignored?
 107 -- TODO: Why not use getNodesWith?
 108 getNodesWithParentId :: (Hyperdata a, JSONB a)
 109                      => Maybe NodeId
 110                      -> Cmd err [Node a]
 111 getNodesWithParentId n = runOpaQuery $ selectNodesWithParentID n'
 112   where
 113     n' = case n of
 114       Just n'' -> n''
 115       Nothing  -> 0
 116
 117
 118 -- | Given a node id, find it's closest parent of given type
 119 -- NOTE: This isn't too optimal: can make successive queries depending on how
 120 -- deeply nested the child is.
 121 getClosestParentIdByType :: HasDBid NodeType
 122                          => NodeId
 123                          -> NodeType
 124                          -> Cmd err (Maybe NodeId)
 125 getClosestParentIdByType nId nType = do
 126   result <- runPGSQuery query (nId, 0 :: Int)
 127   case result of
 128     [(NodeId parentId, pTypename)] -> do
 129       if toDBid nType == pTypename then
 130         pure $ Just $ NodeId parentId
 131       else
 132         getClosestParentIdByType (NodeId parentId) nType
 133     _ -> pure Nothing
 134   where
 135     query :: DPS.Query
 136     query = [sql|
 137       SELECT n2.id, n2.typename
 138       FROM nodes n1
 139         JOIN nodes n2 ON n1.parent_id = n2.id
 140         WHERE n1.id = ? AND 0 = ?;
 141     |]
 142
 143 -- | Similar to `getClosestParentIdByType` but includes current node
 144 -- in search too
 145 getClosestParentIdByType' :: HasDBid NodeType
 146                           => NodeId
 147                           -> NodeType
 148                           -> Cmd err (Maybe NodeId)
 149 getClosestParentIdByType' nId nType = do
 150   result <- runPGSQuery query (nId, 0 :: Int)
 151   case result of
 152     [(NodeId id, pTypename)] -> do
 153       if toDBid nType == pTypename then
 154         pure $ Just $ NodeId id
 155       else
 156         getClosestParentIdByType nId nType
 157     _ -> pure Nothing
 158   where
 159     query :: DPS.Query
 160     query = [sql|
 161       SELECT n.id, n.typename
 162       FROM nodes n
 163       WHERE n.id = ? AND 0 = ?;
 164     |]
 165
 166 -- | Given a node id, find all it's children (no matter how deep) of
 167 -- given node type.
 168 getChildrenByType :: HasDBid NodeType
 169                   => NodeId
 170                   -> NodeType
 171                   -> Cmd err [NodeId]
 172 getChildrenByType nId nType = do
 173   result <- runPGSQuery query (nId, 0 :: Int)
 174   children_lst <- mapM (\(id, _) -> getChildrenByType id nType) result
 175   pure $ concat $ [fst <$> filter (\(_, pTypename) -> pTypename == toDBid nType) result] ++ children_lst
 176   where
 177     query :: DPS.Query
 178     query = [sql|
 179       SELECT n.id, n.typename
 180       FROM nodes n
 181       WHERE n.parent_id = ? AND 0 = ?;
 182     |]
 183
 184 ------------------------------------------------------------------------
 185 getDocumentsV3WithParentId :: HasDBid NodeType => NodeId -> Cmd err [Node HyperdataDocumentV3]
 186 getDocumentsV3WithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeDocument)
 187
 188 -- TODO: merge with getDocumentsWithParentId by having a class IsHyperdataDocument
 189 getDocumentsWithParentId :: HasDBid NodeType => NodeId -> Cmd err [Node HyperdataDocument]
 190 getDocumentsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeDocument)
 191
 192 getListsModelWithParentId :: HasDBid NodeType => NodeId -> Cmd err [Node HyperdataModel]
 193 getListsModelWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeModel)
 194
 195 getCorporaWithParentId :: HasDBid NodeType => NodeId -> Cmd err [Node HyperdataCorpus]
 196 getCorporaWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeCorpus)
 197
 198 ------------------------------------------------------------------------
 199 selectNodesWithParentID :: NodeId -> Select NodeRead
 200 selectNodesWithParentID n = proc () -> do
 201     row@(Node _ _ _ _ parent_id _ _ _) <- queryNodeTable -< ()
 202     restrict -< parent_id .== (pgNodeId n)
 203     returnA -< row
 204
 205
 206 ------------------------------------------------------------------------
 207 -- | Example of use:
 208 -- runCmdReplEasy  (getNodesWithType NodeList (Proxy :: Proxy HyperdataList))
 209 getNodesWithType :: (HasNodeError err, JSONB a, HasDBid NodeType) => NodeType -> proxy a -> Cmd err [Node a]
 210 getNodesWithType nt _ = runOpaQuery $ selectNodesWithType nt
 211   where
 212     selectNodesWithType ::  HasDBid NodeType
 213                          => NodeType -> Select NodeRead
 214     selectNodesWithType nt' = proc () -> do
 215         row@(Node _ _ tn _ _ _ _ _) <- queryNodeTable -< ()
 216         restrict -< tn .== (sqlInt4 $ toDBid nt')
 217         returnA -< row
 218
 219 getNodesIdWithType :: (HasNodeError err, HasDBid NodeType) => NodeType -> Cmd err [NodeId]
 220 getNodesIdWithType nt = do
 221   ns <- runOpaQuery $ selectNodesIdWithType nt
 222   pure (map NodeId ns)
 223
 224 selectNodesIdWithType :: HasDBid NodeType
 225                       => NodeType -> Select (Column SqlInt4)
 226 selectNodesIdWithType nt = proc () -> do
 227     row@(Node _ _ tn _ _ _ _ _) <- queryNodeTable -< ()
 228     restrict -< tn .== (sqlInt4 $ toDBid nt)
 229     returnA -< _node_id row
 230
 231 ------------------------------------------------------------------------
 232
 233 nodeExists :: (HasNodeError err) => NodeId -> Cmd err Bool
 234 nodeExists nId = (== [DPS.Only True])
 235   <$> runPGSQuery [sql|SELECT true FROM nodes WHERE id = ? AND ?|] (nId, True)
 236
 237 getNode :: HasNodeError err => NodeId -> Cmd err (Node Value)
 238 getNode nId = do
 239   maybeNode <- headMay <$> runOpaQuery (selectNode (pgNodeId nId))
 240   case maybeNode of
 241     Nothing -> nodeError (DoesNotExist nId)
 242     Just  r -> pure r
 243
 244 getNodeWith :: (HasNodeError err, JSONB a)
 245             => NodeId -> proxy a -> Cmd err (Node a)
 246 getNodeWith nId _ = do
 247   maybeNode <- headMay <$> runOpaQuery (selectNode (pgNodeId nId))
 248   case maybeNode of
 249     Nothing -> nodeError (DoesNotExist nId)
 250     Just  r -> pure r
 251
 252
 253 ------------------------------------------------------------------------
 254 -- | Sugar to insert Node with NodeType in Database
 255 insertDefaultNode :: HasDBid NodeType
 256                   => NodeType -> ParentId -> UserId -> Cmd err [NodeId]
 257 insertDefaultNode nt p u = insertNode nt Nothing Nothing p u
 258
 259 insertDefaultNodeIfNotExists :: HasDBid NodeType
 260                              => NodeType -> ParentId -> UserId -> Cmd err [NodeId]
 261 insertDefaultNodeIfNotExists nt p u = do
 262   children <- getChildrenByType p nt
 263   case children of
 264     [] -> insertDefaultNode nt p u
 265     xs -> pure xs
 266
 267 insertNode :: HasDBid NodeType
 268            => NodeType -> Maybe Name -> Maybe DefaultHyperdata -> ParentId -> UserId -> Cmd err [NodeId]
 269 insertNode nt n h p u = insertNodesR [nodeW nt n h p u]
 270
 271 nodeW ::  HasDBid NodeType
 272        => NodeType -> Maybe Name -> Maybe DefaultHyperdata -> ParentId -> UserId -> NodeWrite
 273 nodeW nt n h p u = node nt n' h' (Just p) u
 274   where
 275     n' = fromMaybe (defaultName nt) n
 276     h' = maybe     (defaultHyperdata nt) identity h
 277
 278 ------------------------------------------------------------------------
 279 node :: (ToJSON a, Hyperdata a, HasDBid NodeType)
 280      => NodeType
 281      -> Name
 282      -> a
 283      -> Maybe ParentId
 284      -> UserId
 285      -> NodeWrite
 286 node nodeType name hyperData parentId userId =
 287   Node Nothing Nothing
 288        (sqlInt4 typeId)
 289        (sqlInt4 userId)
 290        (pgNodeId <$> parentId)
 291        (sqlStrictText name)
 292        Nothing
 293        (sqlJSONB $ cs $ encode hyperData)
 294     where
 295       typeId = toDBid nodeType
 296
 297                   -------------------------------
 298 insertNodes :: [NodeWrite] -> Cmd err Int64
 299 insertNodes ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeTable ns rCount Nothing
 300
 301 {-
 302 insertNodes' :: [Node a] -> Cmd err Int64
 303 insertNodes' ns = mkCmd $ \conn -> runInsert_ conn
 304                         $ Insert nodeTable ns' rCount Nothing
 305   where
 306     ns' :: [NodeWrite]
 307     ns' = map (\(Node i t u p n d h)
 308                 -> Node (pgNodeId          <$> i)
 309                         (sqlInt4 $ toDBid      t)
 310                         (sqlInt4                u)
 311                         (pgNodeId          <$> p)
 312                         (sqlStrictText          n)
 313                         (pgUTCTime         <$> d)
 314                         (pgJSONB $ cs $ encode h)
 315               ) ns
 316 -}
 317
 318 insertNodesR :: [NodeWrite] -> Cmd err [NodeId]
 319 insertNodesR ns = mkCmd $ \conn ->
 320   runInsert_ conn (Insert nodeTable ns (rReturning (\(Node i _ _ _ _ _ _ _) -> i)) Nothing)
 321
 322 insertNodesWithParent :: Maybe ParentId -> [NodeWrite] -> Cmd err Int64
 323 insertNodesWithParent pid ns = insertNodes (set node_parent_id (pgNodeId <$> pid) <$> ns)
 324
 325 insertNodesWithParentR :: Maybe ParentId -> [NodeWrite] -> Cmd err [NodeId]
 326 insertNodesWithParentR pid ns = insertNodesR (set node_parent_id (pgNodeId <$> pid) <$> ns)
 327 ------------------------------------------------------------------------
 328 -- TODO
 329 -- currently this function removes the child relation
 330 -- needs a Temporary type between Node' and NodeWriteT
 331
 332 node2table :: HasDBid NodeType
 333            => UserId -> Maybe ParentId -> Node' -> NodeWrite
 334 node2table uid pid (Node' nt txt v []) = Node Nothing Nothing (sqlInt4 $ toDBid nt) (sqlInt4 uid) (fmap pgNodeId pid) (sqlStrictText txt) Nothing (sqlStrictJSONB $ cs $ encode v)
 335 node2table _ _ (Node' _ _ _ _) = panic "node2table: should not happen, Tree insert not implemented yet"
 336
 337
 338 data Node' = Node' { _n_type :: NodeType
 339                    , _n_name :: Text
 340                    , _n_data :: Value
 341                    , _n_children :: [Node']
 342                    } deriving (Show)
 343
 344 mkNodes :: [NodeWrite] -> Cmd err Int64
 345 mkNodes ns = mkCmd $ \conn -> runInsert_ conn
 346                    $ Insert nodeTable ns rCount Nothing
 347
 348 mkNodeR :: [NodeWrite] -> Cmd err [NodeId]
 349 mkNodeR ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeTable ns (rReturning _node_id) Nothing
 350
 351 ------------------------------------------------------------------------
 352 childWith ::  HasDBid NodeType
 353            => UserId -> ParentId -> Node' -> NodeWrite
 354 childWith uId pId (Node' NodeDocument txt v []) = node2table uId (Just pId) (Node' NodeDocument txt v [])
 355 childWith uId pId (Node' NodeContact  txt v []) = node2table uId (Just pId) (Node' NodeContact txt v [])
 356 childWith _   _   (Node' _        _   _ _) = panic "This NodeType can not be a child"
 357
 358
 359 -- =================================================================== --
 360 -- |
 361 -- CorpusDocument is a corpus made from a set of documents
 362 -- CorpusContact  is a corpus made from a set of contacts (syn of Annuaire)
 363 data CorpusType = CorpusDocument | CorpusContact
 364
 365 class MkCorpus a
 366   where
 367     mk :: HasDBid NodeType => Maybe Name -> Maybe a -> ParentId -> UserId -> Cmd err [NodeId]
 368
 369 instance MkCorpus HyperdataCorpus
 370   where
 371     mk n Nothing  p u = insertNode NodeCorpus n Nothing p u
 372     mk n (Just h) p u = insertNode NodeCorpus n (Just $ DefaultCorpus h) p u
 373
 374
 375 instance MkCorpus HyperdataAnnuaire
 376   where
 377     mk n Nothing  p u = insertNode NodeCorpus   n Nothing p u
 378     mk n (Just h) p u = insertNode NodeAnnuaire n (Just $ DefaultAnnuaire h) p u
 379
 380
 381 getOrMkList :: (HasNodeError err, HasDBid NodeType)
 382             => ParentId
 383             -> UserId
 384             -> Cmd err ListId
 385 getOrMkList pId uId =
 386   maybe (mkList' pId uId) (pure . view node_id) . headMay =<< getListsWithParentId pId
 387     where
 388       mkList' pId' uId' = maybe (nodeError MkNode) pure . headMay =<< insertDefaultNode NodeList pId' uId'
 389
 390 -- | TODO remove defaultList
 391 defaultList :: (HasNodeError err, HasDBid NodeType) => CorpusId -> Cmd err ListId
 392 defaultList cId =
 393   maybe (nodeError NoListFound) (pure . view node_id) . headMay =<< getListsWithParentId cId
 394
 395 defaultListMaybe :: (HasNodeError err, HasDBid NodeType) => CorpusId -> Cmd err (Maybe NodeId)
 396 defaultListMaybe cId = headMay <$> map (view node_id ) <$> getListsWithParentId cId
 397
 398 getListsWithParentId :: HasDBid NodeType => NodeId -> Cmd err [Node HyperdataList]
 399 getListsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeList)
 400