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