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 = queryTable 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   .== (pgInt4 (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 nodeTable
  89                  (\(Node n_id _ _ _ _ _ _ _) -> n_id .== pgNodeId n)
  90
  91 deleteNodes :: [NodeId] -> Cmd err Int
  92 deleteNodes ns = mkCmd $ \conn ->
  93   fromIntegral <$> runDelete conn nodeTable
  94                    (\(Node n_id _ _ _ _ _ _ _) -> in_ ((map pgNodeId ns)) n_id)
  95
  96 -- TODO: NodeType should match with `a'
  97 getNodesWith :: (JSONB a, HasDBid NodeType) => NodeId -> proxy a -> Maybe NodeType
  98              -> Maybe Offset -> Maybe Limit -> Cmd err [Node a]
  99 getNodesWith parentId _ nodeType maybeOffset maybeLimit =
 100     runOpaQuery $ selectNodesWith parentId nodeType maybeOffset maybeLimit
 101
 102 -- TODO: Why is the second parameter ignored?
 103 -- TODO: Why not use getNodesWith?
 104 getNodesWithParentId :: (Hyperdata a, JSONB a)
 105                      => Maybe NodeId
 106                      -> Cmd err [Node a]
 107 getNodesWithParentId n = runOpaQuery $ selectNodesWithParentID n'
 108   where
 109     n' = case n of
 110       Just n'' -> n''
 111       Nothing  -> 0
 112
 113
 114 -- | Given a node id, find it's closest parent of given type
 115 -- NOTE: This isn't too optimal: can make successive queries depending on how
 116 -- deeply nested the child is.
 117 getClosestParentIdByType :: HasDBid NodeType
 118                          => NodeId
 119                          -> NodeType
 120                          -> Cmd err (Maybe NodeId)
 121 getClosestParentIdByType nId nType = do
 122   result <- runPGSQuery query (nId, 0 :: Int)
 123   case result of
 124     [DPS.Only parentId, DPS.Only pTypename] -> do
 125       if toDBid nType == pTypename then
 126         pure $ Just $ NodeId parentId
 127       else
 128         getClosestParentIdByType (NodeId parentId) nType
 129     _ -> pure Nothing
 130   where
 131     query :: DPS.Query
 132     query = [sql|
 133       SELECT n2.id, n2.typename
 134         FROM nodes n1
 135         JOIN nodes n2 ON n1.parent_id = n2.id
 136         WHERE n1.id = ? AND 0 = ?;
 137     |]
 138
 139 ------------------------------------------------------------------------
 140 getDocumentsV3WithParentId :: HasDBid NodeType => NodeId -> Cmd err [Node HyperdataDocumentV3]
 141 getDocumentsV3WithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeDocument)
 142
 143 -- TODO: merge with getDocumentsWithParentId by having a class IsHyperdataDocument
 144 getDocumentsWithParentId :: HasDBid NodeType => NodeId -> Cmd err [Node HyperdataDocument]
 145 getDocumentsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeDocument)
 146
 147 getListsModelWithParentId :: HasDBid NodeType => NodeId -> Cmd err [Node HyperdataModel]
 148 getListsModelWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeModel)
 149
 150 getCorporaWithParentId :: HasDBid NodeType => NodeId -> Cmd err [Node HyperdataCorpus]
 151 getCorporaWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeCorpus)
 152
 153 ------------------------------------------------------------------------
 154 selectNodesWithParentID :: NodeId -> Query NodeRead
 155 selectNodesWithParentID n = proc () -> do
 156     row@(Node _ _ _ _ parent_id _ _ _) <- queryNodeTable -< ()
 157     restrict -< parent_id .== (pgNodeId n)
 158     returnA -< row
 159
 160
 161 ------------------------------------------------------------------------
 162 -- | Example of use:
 163 -- runCmdReplEasy  (getNodesWithType NodeList (Proxy :: Proxy HyperdataList))
 164 getNodesWithType :: (HasNodeError err, JSONB a, HasDBid NodeType) => NodeType -> proxy a -> Cmd err [Node a]
 165 getNodesWithType nt _ = runOpaQuery $ selectNodesWithType nt
 166   where
 167     selectNodesWithType ::  HasDBid NodeType
 168                          => NodeType -> Query NodeRead
 169     selectNodesWithType nt' = proc () -> do
 170         row@(Node _ _ tn _ _ _ _ _) <- queryNodeTable -< ()
 171         restrict -< tn .== (pgInt4 $ toDBid nt')
 172         returnA -< row
 173
 174 getNodesIdWithType :: (HasNodeError err, HasDBid NodeType) => NodeType -> Cmd err [NodeId]
 175 getNodesIdWithType nt = do
 176   ns <- runOpaQuery $ selectNodesIdWithType nt
 177   pure (map NodeId ns)
 178
 179 selectNodesIdWithType :: HasDBid NodeType
 180                       => NodeType -> Query (Column PGInt4)
 181 selectNodesIdWithType nt = proc () -> do
 182     row@(Node _ _ tn _ _ _ _ _) <- queryNodeTable -< ()
 183     restrict -< tn .== (pgInt4 $ toDBid nt)
 184     returnA -< _node_id row
 185
 186 ------------------------------------------------------------------------
 187
 188
 189 getNode :: HasNodeError err => NodeId -> Cmd err (Node Value)
 190 getNode nId = do
 191   maybeNode <- headMay <$> runOpaQuery (selectNode (pgNodeId nId))
 192   case maybeNode of
 193     Nothing -> nodeError (DoesNotExist nId)
 194     Just  r -> pure r
 195
 196 getNodeWith :: (HasNodeError err, JSONB a)
 197             => NodeId -> proxy a -> Cmd err (Node a)
 198 getNodeWith nId _ = do
 199   maybeNode <- headMay <$> runOpaQuery (selectNode (pgNodeId nId))
 200   case maybeNode of
 201     Nothing -> nodeError (DoesNotExist nId)
 202     Just  r -> pure r
 203
 204
 205 ------------------------------------------------------------------------
 206 -- | Sugar to insert Node with NodeType in Database
 207 insertDefaultNode :: HasDBid NodeType
 208                   => NodeType -> ParentId -> UserId -> Cmd err [NodeId]
 209 insertDefaultNode nt p u = insertNode nt Nothing Nothing p u
 210
 211 insertNode :: HasDBid NodeType
 212            => NodeType -> Maybe Name -> Maybe DefaultHyperdata -> ParentId -> UserId -> Cmd err [NodeId]
 213 insertNode nt n h p u = insertNodesR [nodeW nt n h p u]
 214
 215 nodeW ::  HasDBid NodeType
 216        => NodeType -> Maybe Name -> Maybe DefaultHyperdata -> ParentId -> UserId -> NodeWrite
 217 nodeW nt n h p u = node nt n' h' (Just p) u
 218   where
 219     n' = fromMaybe (defaultName nt) n
 220     h' = maybe     (defaultHyperdata nt) identity h
 221
 222 ------------------------------------------------------------------------
 223 node :: (ToJSON a, Hyperdata a, HasDBid NodeType)
 224      => NodeType
 225      -> Name
 226      -> a
 227      -> Maybe ParentId
 228      -> UserId
 229      -> NodeWrite
 230 node nodeType name hyperData parentId userId =
 231   Node Nothing Nothing
 232        (pgInt4 typeId)
 233        (pgInt4 userId)
 234        (pgNodeId <$> parentId)
 235        (pgStrictText name)
 236        Nothing
 237        (pgJSONB $ cs $ encode hyperData)
 238     where
 239       typeId = toDBid nodeType
 240
 241                   -------------------------------
 242 insertNodes :: [NodeWrite] -> Cmd err Int64
 243 insertNodes ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeTable ns rCount Nothing
 244
 245 {-
 246 insertNodes' :: [Node a] -> Cmd err Int64
 247 insertNodes' ns = mkCmd $ \conn -> runInsert_ conn
 248                         $ Insert nodeTable ns' rCount Nothing
 249   where
 250     ns' :: [NodeWrite]
 251     ns' = map (\(Node i t u p n d h)
 252                 -> Node (pgNodeId          <$> i)
 253                         (pgInt4 $ toDBid      t)
 254                         (pgInt4                u)
 255                         (pgNodeId          <$> p)
 256                         (pgStrictText          n)
 257                         (pgUTCTime         <$> d)
 258                         (pgJSONB $ cs $ encode h)
 259               ) ns
 260 -}
 261
 262 insertNodesR :: [NodeWrite] -> Cmd err [NodeId]
 263 insertNodesR ns = mkCmd $ \conn ->
 264   runInsert_ conn (Insert nodeTable ns (rReturning (\(Node i _ _ _ _ _ _ _) -> i)) Nothing)
 265
 266 insertNodesWithParent :: Maybe ParentId -> [NodeWrite] -> Cmd err Int64
 267 insertNodesWithParent pid ns = insertNodes (set node_parentId (pgNodeId <$> pid) <$> ns)
 268
 269 insertNodesWithParentR :: Maybe ParentId -> [NodeWrite] -> Cmd err [NodeId]
 270 insertNodesWithParentR pid ns = insertNodesR (set node_parentId (pgNodeId <$> pid) <$> ns)
 271 ------------------------------------------------------------------------
 272 -- TODO
 273 -- currently this function removes the child relation
 274 -- needs a Temporary type between Node' and NodeWriteT
 275
 276 node2table :: HasDBid NodeType
 277            => UserId -> Maybe ParentId -> Node' -> NodeWrite
 278 node2table uid pid (Node' nt txt v []) = Node Nothing Nothing (pgInt4 $ toDBid nt) (pgInt4 uid) (fmap pgNodeId pid) (pgStrictText txt) Nothing (pgStrictJSONB $ cs $ encode v)
 279 node2table _ _ (Node' _ _ _ _) = panic "node2table: should not happen, Tree insert not implemented yet"
 280
 281
 282 data Node' = Node' { _n_type :: NodeType
 283                    , _n_name :: Text
 284                    , _n_data :: Value
 285                    , _n_children :: [Node']
 286                    } deriving (Show)
 287
 288 mkNodes :: [NodeWrite] -> Cmd err Int64
 289 mkNodes ns = mkCmd $ \conn -> runInsert_ conn
 290                    $ Insert nodeTable ns rCount Nothing
 291
 292 mkNodeR :: [NodeWrite] -> Cmd err [NodeId]
 293 mkNodeR ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeTable ns (rReturning _node_id) Nothing
 294
 295 ------------------------------------------------------------------------
 296 childWith ::  HasDBid NodeType
 297            => UserId -> ParentId -> Node' -> NodeWrite
 298 childWith uId pId (Node' NodeDocument txt v []) = node2table uId (Just pId) (Node' NodeDocument txt v [])
 299 childWith uId pId (Node' NodeContact  txt v []) = node2table uId (Just pId) (Node' NodeContact txt v [])
 300 childWith _   _   (Node' _        _   _ _) = panic "This NodeType can not be a child"
 301
 302
 303 -- =================================================================== --
 304 -- |
 305 -- CorpusDocument is a corpus made from a set of documents
 306 -- CorpusContact  is a corpus made from a set of contacts (syn of Annuaire)
 307 data CorpusType = CorpusDocument | CorpusContact
 308
 309 class MkCorpus a
 310   where
 311     mk :: HasDBid NodeType => Maybe Name -> Maybe a -> ParentId -> UserId -> Cmd err [NodeId]
 312
 313 instance MkCorpus HyperdataCorpus
 314   where
 315     mk n Nothing  p u = insertNode NodeCorpus n Nothing p u
 316     mk n (Just h) p u = insertNode NodeCorpus n (Just $ DefaultCorpus h) p u
 317
 318
 319 instance MkCorpus HyperdataAnnuaire
 320   where
 321     mk n Nothing  p u = insertNode NodeCorpus   n Nothing p u
 322     mk n (Just h) p u = insertNode NodeAnnuaire n (Just $ DefaultAnnuaire h) p u
 323
 324
 325 getOrMkList :: (HasNodeError err, HasDBid NodeType)
 326             => ParentId
 327             -> UserId
 328             -> Cmd err ListId
 329 getOrMkList pId uId =
 330   maybe (mkList' pId uId) (pure . view node_id) . headMay =<< getListsWithParentId pId
 331     where
 332       mkList' pId' uId' = maybe (nodeError MkNode) pure . headMay =<< insertDefaultNode NodeList pId' uId'
 333
 334 -- | TODO remove defaultList
 335 defaultList :: (HasNodeError err, HasDBid NodeType) => CorpusId -> Cmd err ListId
 336 defaultList cId =
 337   maybe (nodeError NoListFound) (pure . view node_id) . headMay =<< getListsWithParentId cId
 338
 339
 340 getListsWithParentId :: HasDBid NodeType => NodeId -> Cmd err [Node HyperdataList]
 341 getListsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeList)
 342