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
 234 getNode :: HasNodeError err => NodeId -> Cmd err (Node Value)
 235 getNode nId = do
 236   maybeNode <- headMay <$> runOpaQuery (selectNode (pgNodeId nId))
 237   case maybeNode of
 238     Nothing -> nodeError (DoesNotExist nId)
 239     Just  r -> pure r
 240
 241 getNodeWith :: (HasNodeError err, JSONB a)
 242             => NodeId -> proxy a -> Cmd err (Node a)
 243 getNodeWith nId _ = do
 244   maybeNode <- headMay <$> runOpaQuery (selectNode (pgNodeId nId))
 245   case maybeNode of
 246     Nothing -> nodeError (DoesNotExist nId)
 247     Just  r -> pure r
 248
 249
 250 ------------------------------------------------------------------------
 251 -- | Sugar to insert Node with NodeType in Database
 252 insertDefaultNode :: HasDBid NodeType
 253                   => NodeType -> ParentId -> UserId -> Cmd err [NodeId]
 254 insertDefaultNode nt p u = insertNode nt Nothing Nothing p u
 255
 256 insertDefaultNodeIfNotExists :: HasDBid NodeType
 257                              => NodeType -> ParentId -> UserId -> Cmd err [NodeId]
 258 insertDefaultNodeIfNotExists nt p u = do
 259   children <- getChildrenByType p nt
 260   case children of
 261     [] -> insertDefaultNode nt p u
 262     xs -> pure xs
 263
 264 insertNode :: HasDBid NodeType
 265            => NodeType -> Maybe Name -> Maybe DefaultHyperdata -> ParentId -> UserId -> Cmd err [NodeId]
 266 insertNode nt n h p u = insertNodesR [nodeW nt n h p u]
 267
 268 nodeW ::  HasDBid NodeType
 269        => NodeType -> Maybe Name -> Maybe DefaultHyperdata -> ParentId -> UserId -> NodeWrite
 270 nodeW nt n h p u = node nt n' h' (Just p) u
 271   where
 272     n' = fromMaybe (defaultName nt) n
 273     h' = maybe     (defaultHyperdata nt) identity h
 274
 275 ------------------------------------------------------------------------
 276 node :: (ToJSON a, Hyperdata a, HasDBid NodeType)
 277      => NodeType
 278      -> Name
 279      -> a
 280      -> Maybe ParentId
 281      -> UserId
 282      -> NodeWrite
 283 node nodeType name hyperData parentId userId =
 284   Node Nothing Nothing
 285        (sqlInt4 typeId)
 286        (sqlInt4 userId)
 287        (pgNodeId <$> parentId)
 288        (sqlStrictText name)
 289        Nothing
 290        (sqlJSONB $ cs $ encode hyperData)
 291     where
 292       typeId = toDBid nodeType
 293
 294                   -------------------------------
 295 insertNodes :: [NodeWrite] -> Cmd err Int64
 296 insertNodes ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeTable ns rCount Nothing
 297
 298 {-
 299 insertNodes' :: [Node a] -> Cmd err Int64
 300 insertNodes' ns = mkCmd $ \conn -> runInsert_ conn
 301                         $ Insert nodeTable ns' rCount Nothing
 302   where
 303     ns' :: [NodeWrite]
 304     ns' = map (\(Node i t u p n d h)
 305                 -> Node (pgNodeId          <$> i)
 306                         (sqlInt4 $ toDBid      t)
 307                         (sqlInt4                u)
 308                         (pgNodeId          <$> p)
 309                         (sqlStrictText          n)
 310                         (pgUTCTime         <$> d)
 311                         (pgJSONB $ cs $ encode h)
 312               ) ns
 313 -}
 314
 315 insertNodesR :: [NodeWrite] -> Cmd err [NodeId]
 316 insertNodesR ns = mkCmd $ \conn ->
 317   runInsert_ conn (Insert nodeTable ns (rReturning (\(Node i _ _ _ _ _ _ _) -> i)) Nothing)
 318
 319 insertNodesWithParent :: Maybe ParentId -> [NodeWrite] -> Cmd err Int64
 320 insertNodesWithParent pid ns = insertNodes (set node_parent_id (pgNodeId <$> pid) <$> ns)
 321
 322 insertNodesWithParentR :: Maybe ParentId -> [NodeWrite] -> Cmd err [NodeId]
 323 insertNodesWithParentR pid ns = insertNodesR (set node_parent_id (pgNodeId <$> pid) <$> ns)
 324 ------------------------------------------------------------------------
 325 -- TODO
 326 -- currently this function removes the child relation
 327 -- needs a Temporary type between Node' and NodeWriteT
 328
 329 node2table :: HasDBid NodeType
 330            => UserId -> Maybe ParentId -> Node' -> NodeWrite
 331 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)
 332 node2table _ _ (Node' _ _ _ _) = panic "node2table: should not happen, Tree insert not implemented yet"
 333
 334
 335 data Node' = Node' { _n_type :: NodeType
 336                    , _n_name :: Text
 337                    , _n_data :: Value
 338                    , _n_children :: [Node']
 339                    } deriving (Show)
 340
 341 mkNodes :: [NodeWrite] -> Cmd err Int64
 342 mkNodes ns = mkCmd $ \conn -> runInsert_ conn
 343                    $ Insert nodeTable ns rCount Nothing
 344
 345 mkNodeR :: [NodeWrite] -> Cmd err [NodeId]
 346 mkNodeR ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeTable ns (rReturning _node_id) Nothing
 347
 348 ------------------------------------------------------------------------
 349 childWith ::  HasDBid NodeType
 350            => UserId -> ParentId -> Node' -> NodeWrite
 351 childWith uId pId (Node' NodeDocument txt v []) = node2table uId (Just pId) (Node' NodeDocument txt v [])
 352 childWith uId pId (Node' NodeContact  txt v []) = node2table uId (Just pId) (Node' NodeContact txt v [])
 353 childWith _   _   (Node' _        _   _ _) = panic "This NodeType can not be a child"
 354
 355
 356 -- =================================================================== --
 357 -- |
 358 -- CorpusDocument is a corpus made from a set of documents
 359 -- CorpusContact  is a corpus made from a set of contacts (syn of Annuaire)
 360 data CorpusType = CorpusDocument | CorpusContact
 361
 362 class MkCorpus a
 363   where
 364     mk :: HasDBid NodeType => Maybe Name -> Maybe a -> ParentId -> UserId -> Cmd err [NodeId]
 365
 366 instance MkCorpus HyperdataCorpus
 367   where
 368     mk n Nothing  p u = insertNode NodeCorpus n Nothing p u
 369     mk n (Just h) p u = insertNode NodeCorpus n (Just $ DefaultCorpus h) p u
 370
 371
 372 instance MkCorpus HyperdataAnnuaire
 373   where
 374     mk n Nothing  p u = insertNode NodeCorpus   n Nothing p u
 375     mk n (Just h) p u = insertNode NodeAnnuaire n (Just $ DefaultAnnuaire h) p u
 376
 377
 378 getOrMkList :: (HasNodeError err, HasDBid NodeType)
 379             => ParentId
 380             -> UserId
 381             -> Cmd err ListId
 382 getOrMkList pId uId =
 383   maybe (mkList' pId uId) (pure . view node_id) . headMay =<< getListsWithParentId pId
 384     where
 385       mkList' pId' uId' = maybe (nodeError MkNode) pure . headMay =<< insertDefaultNode NodeList pId' uId'
 386
 387 -- | TODO remove defaultList
 388 defaultList :: (HasNodeError err, HasDBid NodeType) => CorpusId -> Cmd err ListId
 389 defaultList cId =
 390   maybe (nodeError NoListFound) (pure . view node_id) . headMay =<< getListsWithParentId cId
 391
 392 defaultListMaybe :: (HasNodeError err, HasDBid NodeType) => CorpusId -> Cmd err (Maybe NodeId)
 393 defaultListMaybe cId = headMay <$> map (view node_id ) <$> getListsWithParentId cId
 394
 395 getListsWithParentId :: HasDBid NodeType => NodeId -> Cmd err [Node HyperdataList]
 396 getListsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeList)
 397