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 :: Query NodeSearchRead
  47 queryNodeSearchTable = selectTable nodeTableSearch
  48
  49 selectNode :: Column PGInt4 -> Query NodeRead
  50 selectNode id' = proc () -> do
  51     row      <- queryNodeTable -< ()
  52     restrict -< _node_id row .== id'
  53     returnA  -< row
  54
  55 runGetNodes :: Query 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   -> Query 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 -> Query 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 (pgBool 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 ------------------------------------------------------------------------
 146 getDocumentsV3WithParentId :: HasDBid NodeType => NodeId -> Cmd err [Node HyperdataDocumentV3]
 147 getDocumentsV3WithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeDocument)
 148
 149 -- TODO: merge with getDocumentsWithParentId by having a class IsHyperdataDocument
 150 getDocumentsWithParentId :: HasDBid NodeType => NodeId -> Cmd err [Node HyperdataDocument]
 151 getDocumentsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeDocument)
 152
 153 getListsModelWithParentId :: HasDBid NodeType => NodeId -> Cmd err [Node HyperdataModel]
 154 getListsModelWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeModel)
 155
 156 getCorporaWithParentId :: HasDBid NodeType => NodeId -> Cmd err [Node HyperdataCorpus]
 157 getCorporaWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeCorpus)
 158
 159 ------------------------------------------------------------------------
 160 selectNodesWithParentID :: NodeId -> Query NodeRead
 161 selectNodesWithParentID n = proc () -> do
 162     row@(Node _ _ _ _ parent_id _ _ _) <- queryNodeTable -< ()
 163     restrict -< parent_id .== (pgNodeId n)
 164     returnA -< row
 165
 166
 167 ------------------------------------------------------------------------
 168 -- | Example of use:
 169 -- runCmdReplEasy  (getNodesWithType NodeList (Proxy :: Proxy HyperdataList))
 170 getNodesWithType :: (HasNodeError err, JSONB a, HasDBid NodeType) => NodeType -> proxy a -> Cmd err [Node a]
 171 getNodesWithType nt _ = runOpaQuery $ selectNodesWithType nt
 172   where
 173     selectNodesWithType ::  HasDBid NodeType
 174                          => NodeType -> Query NodeRead
 175     selectNodesWithType nt' = proc () -> do
 176         row@(Node _ _ tn _ _ _ _ _) <- queryNodeTable -< ()
 177         restrict -< tn .== (sqlInt4 $ toDBid nt')
 178         returnA -< row
 179
 180 getNodesIdWithType :: (HasNodeError err, HasDBid NodeType) => NodeType -> Cmd err [NodeId]
 181 getNodesIdWithType nt = do
 182   ns <- runOpaQuery $ selectNodesIdWithType nt
 183   pure (map NodeId ns)
 184
 185 selectNodesIdWithType :: HasDBid NodeType
 186                       => NodeType -> Query (Column PGInt4)
 187 selectNodesIdWithType nt = proc () -> do
 188     row@(Node _ _ tn _ _ _ _ _) <- queryNodeTable -< ()
 189     restrict -< tn .== (sqlInt4 $ toDBid nt)
 190     returnA -< _node_id row
 191
 192 ------------------------------------------------------------------------
 193
 194
 195 getNode :: HasNodeError err => NodeId -> Cmd err (Node Value)
 196 getNode nId = do
 197   maybeNode <- headMay <$> runOpaQuery (selectNode (pgNodeId nId))
 198   case maybeNode of
 199     Nothing -> nodeError (DoesNotExist nId)
 200     Just  r -> pure r
 201
 202 getNodeWith :: (HasNodeError err, JSONB a)
 203             => NodeId -> proxy a -> Cmd err (Node a)
 204 getNodeWith nId _ = do
 205   maybeNode <- headMay <$> runOpaQuery (selectNode (pgNodeId nId))
 206   case maybeNode of
 207     Nothing -> nodeError (DoesNotExist nId)
 208     Just  r -> pure r
 209
 210
 211 ------------------------------------------------------------------------
 212 -- | Sugar to insert Node with NodeType in Database
 213 insertDefaultNode :: HasDBid NodeType
 214                   => NodeType -> ParentId -> UserId -> Cmd err [NodeId]
 215 insertDefaultNode nt p u = insertNode nt Nothing Nothing p u
 216
 217 insertNode :: HasDBid NodeType
 218            => NodeType -> Maybe Name -> Maybe DefaultHyperdata -> ParentId -> UserId -> Cmd err [NodeId]
 219 insertNode nt n h p u = insertNodesR [nodeW nt n h p u]
 220
 221 nodeW ::  HasDBid NodeType
 222        => NodeType -> Maybe Name -> Maybe DefaultHyperdata -> ParentId -> UserId -> NodeWrite
 223 nodeW nt n h p u = node nt n' h' (Just p) u
 224   where
 225     n' = fromMaybe (defaultName nt) n
 226     h' = maybe     (defaultHyperdata nt) identity h
 227
 228 ------------------------------------------------------------------------
 229 node :: (ToJSON a, Hyperdata a, HasDBid NodeType)
 230      => NodeType
 231      -> Name
 232      -> a
 233      -> Maybe ParentId
 234      -> UserId
 235      -> NodeWrite
 236 node nodeType name hyperData parentId userId =
 237   Node Nothing Nothing
 238        (sqlInt4 typeId)
 239        (sqlInt4 userId)
 240        (pgNodeId <$> parentId)
 241        (sqlStrictText name)
 242        Nothing
 243        (pgJSONB $ cs $ encode hyperData)
 244     where
 245       typeId = toDBid nodeType
 246
 247                   -------------------------------
 248 insertNodes :: [NodeWrite] -> Cmd err Int64
 249 insertNodes ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeTable ns rCount Nothing
 250
 251 {-
 252 insertNodes' :: [Node a] -> Cmd err Int64
 253 insertNodes' ns = mkCmd $ \conn -> runInsert_ conn
 254                         $ Insert nodeTable ns' rCount Nothing
 255   where
 256     ns' :: [NodeWrite]
 257     ns' = map (\(Node i t u p n d h)
 258                 -> Node (pgNodeId          <$> i)
 259                         (sqlInt4 $ toDBid      t)
 260                         (sqlInt4                u)
 261                         (pgNodeId          <$> p)
 262                         (sqlStrictText          n)
 263                         (pgUTCTime         <$> d)
 264                         (pgJSONB $ cs $ encode h)
 265               ) ns
 266 -}
 267
 268 insertNodesR :: [NodeWrite] -> Cmd err [NodeId]
 269 insertNodesR ns = mkCmd $ \conn ->
 270   runInsert_ conn (Insert nodeTable ns (rReturning (\(Node i _ _ _ _ _ _ _) -> i)) Nothing)
 271
 272 insertNodesWithParent :: Maybe ParentId -> [NodeWrite] -> Cmd err Int64
 273 insertNodesWithParent pid ns = insertNodes (set node_parent_id (pgNodeId <$> pid) <$> ns)
 274
 275 insertNodesWithParentR :: Maybe ParentId -> [NodeWrite] -> Cmd err [NodeId]
 276 insertNodesWithParentR pid ns = insertNodesR (set node_parent_id (pgNodeId <$> pid) <$> ns)
 277 ------------------------------------------------------------------------
 278 -- TODO
 279 -- currently this function removes the child relation
 280 -- needs a Temporary type between Node' and NodeWriteT
 281
 282 node2table :: HasDBid NodeType
 283            => UserId -> Maybe ParentId -> Node' -> NodeWrite
 284 node2table uid pid (Node' nt txt v []) = Node Nothing Nothing (sqlInt4 $ toDBid nt) (sqlInt4 uid) (fmap pgNodeId pid) (sqlStrictText txt) Nothing (pgStrictJSONB $ cs $ encode v)
 285 node2table _ _ (Node' _ _ _ _) = panic "node2table: should not happen, Tree insert not implemented yet"
 286
 287
 288 data Node' = Node' { _n_type :: NodeType
 289                    , _n_name :: Text
 290                    , _n_data :: Value
 291                    , _n_children :: [Node']
 292                    } deriving (Show)
 293
 294 mkNodes :: [NodeWrite] -> Cmd err Int64
 295 mkNodes ns = mkCmd $ \conn -> runInsert_ conn
 296                    $ Insert nodeTable ns rCount Nothing
 297
 298 mkNodeR :: [NodeWrite] -> Cmd err [NodeId]
 299 mkNodeR ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeTable ns (rReturning _node_id) Nothing
 300
 301 ------------------------------------------------------------------------
 302 childWith ::  HasDBid NodeType
 303            => UserId -> ParentId -> Node' -> NodeWrite
 304 childWith uId pId (Node' NodeDocument txt v []) = node2table uId (Just pId) (Node' NodeDocument txt v [])
 305 childWith uId pId (Node' NodeContact  txt v []) = node2table uId (Just pId) (Node' NodeContact txt v [])
 306 childWith _   _   (Node' _        _   _ _) = panic "This NodeType can not be a child"
 307
 308
 309 -- =================================================================== --
 310 -- |
 311 -- CorpusDocument is a corpus made from a set of documents
 312 -- CorpusContact  is a corpus made from a set of contacts (syn of Annuaire)
 313 data CorpusType = CorpusDocument | CorpusContact
 314
 315 class MkCorpus a
 316   where
 317     mk :: HasDBid NodeType => Maybe Name -> Maybe a -> ParentId -> UserId -> Cmd err [NodeId]
 318
 319 instance MkCorpus HyperdataCorpus
 320   where
 321     mk n Nothing  p u = insertNode NodeCorpus n Nothing p u
 322     mk n (Just h) p u = insertNode NodeCorpus n (Just $ DefaultCorpus h) p u
 323
 324
 325 instance MkCorpus HyperdataAnnuaire
 326   where
 327     mk n Nothing  p u = insertNode NodeCorpus   n Nothing p u
 328     mk n (Just h) p u = insertNode NodeAnnuaire n (Just $ DefaultAnnuaire h) p u
 329
 330
 331 getOrMkList :: (HasNodeError err, HasDBid NodeType)
 332             => ParentId
 333             -> UserId
 334             -> Cmd err ListId
 335 getOrMkList pId uId =
 336   maybe (mkList' pId uId) (pure . view node_id) . headMay =<< getListsWithParentId pId
 337     where
 338       mkList' pId' uId' = maybe (nodeError MkNode) pure . headMay =<< insertDefaultNode NodeList pId' uId'
 339
 340 -- | TODO remove defaultList
 341 defaultList :: (HasNodeError err, HasDBid NodeType) => CorpusId -> Cmd err ListId
 342 defaultList cId =
 343   maybe (nodeError NoListFound) (pure . view node_id) . headMay =<< getListsWithParentId cId
 344
 345 defaultListMaybe :: (HasNodeError err, HasDBid NodeType) => CorpusId -> Cmd err (Maybe NodeId)
 346 defaultListMaybe cId = headMay <$> map (view node_id ) <$> getListsWithParentId cId
 347
 348
 349 getListsWithParentId :: HasDBid NodeType => NodeId -> Cmd err [Node HyperdataList]
 350 getListsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeList)
 351