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