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
  13 {-# OPTIONS_GHC -fno-warn-orphans        #-}
  14
  15 {-# LANGUAGE Arrows                 #-}
  16 {-# LANGUAGE ConstraintKinds        #-}
  17 {-# LANGUAGE FunctionalDependencies #-}
  18 {-# LANGUAGE QuasiQuotes       #-}
  19 {-# LANGUAGE TemplateHaskell        #-}
  20 {-# LANGUAGE TypeFamilies           #-}
  21
  22 module Gargantext.Database.Query.Table.Node
  23   where
  24
  25 import Control.Arrow (returnA)
  26 import Control.Lens (set, view)
  27 import Data.Aeson
  28 import Data.Maybe (fromMaybe)
  29 import Data.Text (Text)
  30 import qualified Database.PostgreSQL.Simple as DPS
  31 import Database.PostgreSQL.Simple.SqlQQ (sql)
  32 import Opaleye hiding (FromField)
  33 import Prelude hiding (null, id, map, sum)
  34
  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 import Gargantext.Database.Query.Filter (limit', offset')
  41 import Gargantext.Database.Query.Table.Node.Error
  42 import Gargantext.Database.Schema.Node
  43 import Gargantext.Prelude hiding (sum, head)
  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 (nId, 0 :: Int)
 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 :: DPS.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 = ? AND 0 = ?;
 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 (nId, 0 :: Int)
 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 :: DPS.Query
 162     query = [sql|
 163       SELECT n.id, n.typename
 164       FROM nodes n
 165       WHERE n.id = ? AND 0 = ?;
 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 (nId, 0 :: Int)
 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 :: DPS.Query
 180     query = [sql|
 181       SELECT n.id, n.typename
 182       FROM nodes n
 183       WHERE n.parent_id = ? AND 0 = ?;
 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
 236 getNode :: HasNodeError err => NodeId -> Cmd err (Node Value)
 237 getNode nId = do
 238   maybeNode <- headMay <$> runOpaQuery (selectNode (pgNodeId nId))
 239   case maybeNode of
 240     Nothing -> nodeError (DoesNotExist nId)
 241     Just  r -> pure r
 242
 243 getNodeWith :: (HasNodeError err, JSONB a)
 244             => NodeId -> proxy a -> Cmd err (Node a)
 245 getNodeWith nId _ = do
 246   maybeNode <- headMay <$> runOpaQuery (selectNode (pgNodeId nId))
 247   case maybeNode of
 248     Nothing -> nodeError (DoesNotExist nId)
 249     Just  r -> pure r
 250
 251
 252 ------------------------------------------------------------------------
 253 -- | Sugar to insert Node with NodeType in Database
 254 insertDefaultNode :: HasDBid NodeType
 255                   => NodeType -> ParentId -> UserId -> Cmd err [NodeId]
 256 insertDefaultNode nt p u = insertNode nt Nothing Nothing p u
 257
 258 insertNode :: HasDBid NodeType
 259            => 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 nodeW ::  HasDBid NodeType
 263        => 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     n' = fromMaybe (defaultName nt) n
 267     h' = maybe     (defaultHyperdata nt) identity h
 268
 269 ------------------------------------------------------------------------
 270 node :: (ToJSON a, Hyperdata a, HasDBid NodeType)
 271      => NodeType
 272      -> Name
 273      -> a
 274      -> Maybe ParentId
 275      -> UserId
 276      -> NodeWrite
 277 node nodeType name hyperData parentId userId =
 278   Node Nothing Nothing
 279        (sqlInt4 typeId)
 280        (sqlInt4 userId)
 281        (pgNodeId <$> parentId)
 282        (sqlStrictText name)
 283        Nothing
 284        (sqlJSONB $ cs $ encode hyperData)
 285     where
 286       typeId = toDBid nodeType
 287
 288                   -------------------------------
 289 insertNodes :: [NodeWrite] -> Cmd err Int64
 290 insertNodes ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeTable ns rCount Nothing
 291
 292 {-
 293 insertNodes' :: [Node a] -> Cmd err Int64
 294 insertNodes' ns = mkCmd $ \conn -> runInsert_ conn
 295                         $ Insert nodeTable ns' rCount Nothing
 296   where
 297     ns' :: [NodeWrite]
 298     ns' = map (\(Node i t u p n d h)
 299                 -> Node (pgNodeId          <$> i)
 300                         (sqlInt4 $ toDBid      t)
 301                         (sqlInt4                u)
 302                         (pgNodeId          <$> p)
 303                         (sqlStrictText          n)
 304                         (pgUTCTime         <$> d)
 305                         (pgJSONB $ cs $ encode h)
 306               ) ns
 307 -}
 308
 309 insertNodesR :: [NodeWrite] -> Cmd err [NodeId]
 310 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 -- TODO
 320 -- currently this function removes the child relation
 321 -- needs a Temporary type between Node' and NodeWriteT
 322
 323 node2table :: HasDBid NodeType
 324            => 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 (sqlStrictJSONB $ cs $ encode v)
 326 node2table _ _ (Node' _ _ _ _) = panic "node2table: should not happen, Tree insert not implemented yet"
 327
 328
 329 data Node' = Node' { _n_type :: NodeType
 330                    , _n_name :: Text
 331                    , _n_data :: Value
 332                    , _n_children :: [Node']
 333                    } deriving (Show)
 334
 335 mkNodes :: [NodeWrite] -> Cmd err Int64
 336 mkNodes ns = mkCmd $ \conn -> runInsert_ conn
 337                    $ Insert nodeTable ns rCount Nothing
 338
 339 mkNodeR :: [NodeWrite] -> Cmd err [NodeId]
 340 mkNodeR ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeTable ns (rReturning _node_id) Nothing
 341
 342 ------------------------------------------------------------------------
 343 childWith ::  HasDBid NodeType
 344            => UserId -> ParentId -> Node' -> NodeWrite
 345 childWith uId pId (Node' NodeDocument txt v []) = node2table uId (Just pId) (Node' NodeDocument txt v [])
 346 childWith uId pId (Node' NodeContact  txt v []) = node2table uId (Just pId) (Node' NodeContact txt v [])
 347 childWith _   _   (Node' _        _   _ _) = panic "This NodeType can not be a child"
 348
 349
 350 -- =================================================================== --
 351 -- |
 352 -- CorpusDocument is a corpus made from a set of documents
 353 -- CorpusContact  is a corpus made from a set of contacts (syn of Annuaire)
 354 data CorpusType = CorpusDocument | CorpusContact
 355
 356 class MkCorpus a
 357   where
 358     mk :: HasDBid NodeType => Maybe Name -> Maybe a -> ParentId -> UserId -> Cmd err [NodeId]
 359
 360 instance MkCorpus HyperdataCorpus
 361   where
 362     mk n Nothing  p u = insertNode NodeCorpus n Nothing p u
 363     mk n (Just h) p u = insertNode NodeCorpus n (Just $ DefaultCorpus h) p u
 364
 365
 366 instance MkCorpus HyperdataAnnuaire
 367   where
 368     mk n Nothing  p u = insertNode NodeCorpus   n Nothing p u
 369     mk n (Just h) p u = insertNode NodeAnnuaire n (Just $ DefaultAnnuaire h) p u
 370
 371
 372 getOrMkList :: (HasNodeError err, HasDBid NodeType)
 373             => ParentId
 374             -> UserId
 375             -> Cmd err ListId
 376 getOrMkList pId uId =
 377   maybe (mkList' pId uId) (pure . view node_id) . headMay =<< getListsWithParentId pId
 378     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 defaultList cId =
 384   maybe (nodeError NoListFound) (pure . view node_id) . headMay =<< getListsWithParentId cId
 385
 386 defaultListMaybe :: (HasNodeError err, HasDBid NodeType) => CorpusId -> Cmd err (Maybe NodeId)
 387 defaultListMaybe cId = headMay <$> map (view node_id ) <$> getListsWithParentId cId
 388
 389 getListsWithParentId :: HasDBid NodeType => NodeId -> Cmd err [Node HyperdataList]
 390 getListsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeList)
 391