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