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 (Maybe(..), fromMaybe, maybe)
  29 import Data.Text (Text)
  30 import qualified Database.PostgreSQL.Simple as DPS
  31 import Database.PostgreSQL.Simple.SqlQQ (sql)
  32 import GHC.Int (Int64)
  33 import Opaleye hiding (FromField)
  34 import Opaleye.Internal.QueryArr (Query)
  35 import Prelude hiding (null, id, map, sum)
  36
  37 import Gargantext.Core.Types
  38 import Gargantext.Database.Admin.Config (nodeTypeId)
  39 import Gargantext.Database.Admin.Types.Hyperdata
  40 import Gargantext.Database.Admin.Types.Hyperdata.Default
  41 import Gargantext.Database.Admin.Types.Node (NodeType(..), defaultName)
  42 import Gargantext.Database.Prelude
  43 import Gargantext.Database.Query.Filter (limit', offset')
  44 import Gargantext.Database.Query.Table.Node.Error
  45 import Gargantext.Database.Schema.Node
  46 import Gargantext.Prelude hiding (sum, head)
  47
  48
  49 queryNodeSearchTable :: Query NodeSearchRead
  50 queryNodeSearchTable = queryTable nodeTableSearch
  51
  52 selectNode :: Column PGInt4 -> Query NodeRead
  53 selectNode id = proc () -> do
  54     row      <- queryNodeTable -< ()
  55     restrict -< _node_id row .== id
  56     returnA  -< row
  57
  58 runGetNodes :: Query NodeRead -> Cmd err [Node HyperdataAny]
  59 runGetNodes = runOpaQuery
  60
  61 ------------------------------------------------------------------------
  62 ------------------------------------------------------------------------
  63 -- | order by publication date
  64 -- Favorites (Bool), node_ngrams
  65 selectNodesWith :: ParentId     -> Maybe NodeType
  66                 -> Maybe Offset -> Maybe Limit   -> Query NodeRead
  67 selectNodesWith parentId maybeNodeType maybeOffset maybeLimit =
  68         --offset' maybeOffset $ limit' maybeLimit $ orderBy (asc (hyperdataDocument_Publication_date . node_hyperdata)) $ selectNodesWith' parentId typeId
  69   limit' maybeLimit $ offset' maybeOffset
  70                     $ orderBy (asc _node_id)
  71                     $ selectNodesWith' parentId maybeNodeType
  72
  73 selectNodesWith' :: ParentId -> Maybe NodeType -> Query 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 nodeTypeId maybeNodeType
  80
  81       restrict -< if typeId' > 0
  82                      then typeId   .== (pgInt4 (typeId' :: Int))
  83                      else (pgBool True)
  84       returnA  -< row ) -< ()
  85     returnA -< node
  86
  87 deleteNode :: NodeId -> Cmd err Int
  88 deleteNode n = mkCmd $ \conn ->
  89   fromIntegral <$> runDelete conn nodeTable
  90                  (\(Node n_id _ _ _ _ _ _) -> n_id .== pgNodeId n)
  91
  92 deleteNodes :: [NodeId] -> Cmd err Int
  93 deleteNodes ns = mkCmd $ \conn ->
  94   fromIntegral <$> runDelete conn nodeTable
  95                    (\(Node n_id _ _ _ _ _ _) -> in_ ((map pgNodeId ns)) n_id)
  96
  97 -- TODO: NodeType should match with `a'
  98 getNodesWith :: JSONB a => NodeId -> proxy a -> Maybe NodeType
  99              -> Maybe Offset -> Maybe Limit -> Cmd err [Node a]
 100 getNodesWith parentId _ nodeType maybeOffset maybeLimit =
 101     runOpaQuery $ selectNodesWith parentId nodeType maybeOffset maybeLimit
 102
 103 -- TODO: Why is the second parameter ignored?
 104 -- TODO: Why not use getNodesWith?
 105 getNodesWithParentId :: (Hyperdata a, QueryRunnerColumnDefault PGJsonb a)
 106                      => Maybe NodeId
 107                      -> Cmd err [Node a]
 108 getNodesWithParentId n = runOpaQuery $ selectNodesWithParentID n'
 109   where
 110     n' = case n of
 111       Just n'' -> n''
 112       Nothing  -> 0
 113
 114
 115 -- | Given a node id, find it's closest parent of given type
 116 -- NOTE: This isn't too optimal: can make successive queries depending on how
 117 -- deeply nested the child is.
 118 getClosestParentIdByType :: 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 nodeTypeId 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 :: 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 :: NodeId -> Cmd err [Node HyperdataDocument]
 145 getDocumentsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeDocument)
 146
 147 getListsModelWithParentId :: NodeId -> Cmd err [Node HyperdataModel]
 148 getListsModelWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeModel)
 149
 150 getCorporaWithParentId :: 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 selectNodesWithType :: Column PGInt4 -> Query NodeRead
 161 selectNodesWithType type_id = proc () -> do
 162     row@(Node _ tn _ _ _ _ _) <- queryNodeTable -< ()
 163     restrict -< tn .== type_id
 164     returnA -< row
 165
 166 type JSONB = QueryRunnerColumnDefault PGJsonb
 167
 168
 169 getNode :: HasNodeError err => NodeId -> Cmd err (Node Value)
 170 getNode nId = do
 171   maybeNode <- headMay <$> runOpaQuery (selectNode (pgNodeId nId))
 172   case maybeNode of
 173     Nothing -> nodeError (DoesNotExist nId)
 174     Just  r -> pure r
 175
 176 getNodeWith :: (HasNodeError err, JSONB a)
 177             => NodeId -> proxy a -> Cmd err (Node a)
 178 getNodeWith nId _ = do
 179   maybeNode <- headMay <$> runOpaQuery (selectNode (pgNodeId nId))
 180   case maybeNode of
 181     Nothing -> nodeError (DoesNotExist nId)
 182     Just  r -> pure r
 183
 184
 185 ------------------------------------------------------------------------
 186 -- | Sugar to insert Node with NodeType in Database
 187 insertDefaultNode :: NodeType -> ParentId -> UserId -> Cmd err [NodeId]
 188 insertDefaultNode nt p u = insertNode nt Nothing Nothing p u
 189
 190 insertNode :: NodeType -> Maybe Name -> Maybe DefaultHyperdata -> ParentId -> UserId -> Cmd err [NodeId]
 191 insertNode nt n h p u = insertNodesR [nodeW nt n h p u]
 192
 193 nodeW :: NodeType -> Maybe Name -> Maybe DefaultHyperdata -> ParentId -> UserId -> NodeWrite
 194 nodeW nt n h p u = node nt n' h' (Just p) u
 195   where
 196     n' = fromMaybe (defaultName nt) n
 197     h' = maybe     (defaultHyperdata nt) identity h
 198
 199 ------------------------------------------------------------------------
 200 node :: (ToJSON a, Hyperdata a)
 201      => NodeType
 202      -> Name
 203      -> a
 204      -> Maybe ParentId
 205      -> UserId
 206      -> NodeWrite
 207 node nodeType name hyperData parentId userId =
 208   Node Nothing
 209        (pgInt4 typeId)
 210        (pgInt4 userId)
 211        (pgNodeId <$> parentId)
 212        (pgStrictText name)
 213        Nothing
 214        (pgJSONB $ cs $ encode hyperData)
 215     where
 216       typeId = nodeTypeId nodeType
 217
 218                   -------------------------------
 219 insertNodes :: [NodeWrite] -> Cmd err Int64
 220 insertNodes ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeTable ns rCount Nothing
 221
 222 {-
 223 insertNodes' :: [Node a] -> Cmd err Int64
 224 insertNodes' ns = mkCmd $ \conn -> runInsert_ conn
 225                         $ Insert nodeTable ns' rCount Nothing
 226   where
 227     ns' :: [NodeWrite]
 228     ns' = map (\(Node i t u p n d h)
 229                 -> Node (pgNodeId          <$> i)
 230                         (pgInt4 $ nodeTypeId   t)
 231                         (pgInt4                u)
 232                         (pgNodeId          <$> p)
 233                         (pgStrictText          n)
 234                         (pgUTCTime         <$> d)
 235                         (pgJSONB $ cs $ encode h)
 236               ) ns
 237 -}
 238
 239 insertNodesR :: [NodeWrite] -> Cmd err [NodeId]
 240 insertNodesR ns = mkCmd $ \conn ->
 241   runInsert_ conn (Insert nodeTable ns (rReturning (\(Node i _ _ _ _ _ _) -> i)) Nothing)
 242
 243 insertNodesWithParent :: Maybe ParentId -> [NodeWrite] -> Cmd err Int64
 244 insertNodesWithParent pid ns = insertNodes (set node_parentId (pgNodeId <$> pid) <$> ns)
 245
 246 insertNodesWithParentR :: Maybe ParentId -> [NodeWrite] -> Cmd err [NodeId]
 247 insertNodesWithParentR pid ns = insertNodesR (set node_parentId (pgNodeId <$> pid) <$> ns)
 248 ------------------------------------------------------------------------
 249 -- TODO
 250 -- currently this function removes the child relation
 251 -- needs a Temporary type between Node' and NodeWriteT
 252
 253 node2table :: UserId -> Maybe ParentId -> Node' -> NodeWrite
 254 node2table uid pid (Node' nt txt v []) = Node Nothing (pgInt4 $ nodeTypeId nt) (pgInt4 uid) (fmap pgNodeId pid) (pgStrictText txt) Nothing (pgStrictJSONB $ cs $ encode v)
 255 node2table _ _ (Node' _ _ _ _) = panic "node2table: should not happen, Tree insert not implemented yet"
 256
 257
 258 data Node' = Node' { _n_type :: NodeType
 259                    , _n_name :: Text
 260                    , _n_data :: Value
 261                    , _n_children :: [Node']
 262                    } deriving (Show)
 263
 264 mkNodes :: [NodeWrite] -> Cmd err Int64
 265 mkNodes ns = mkCmd $ \conn -> runInsert_ conn
 266                    $ Insert nodeTable ns rCount Nothing
 267
 268 mkNodeR :: [NodeWrite] -> Cmd err [NodeId]
 269 mkNodeR ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeTable ns (rReturning _node_id) Nothing
 270
 271 ------------------------------------------------------------------------
 272 childWith :: UserId -> ParentId -> Node' -> NodeWrite
 273 childWith uId pId (Node' NodeDocument txt v []) = node2table uId (Just pId) (Node' NodeDocument txt v [])
 274 childWith uId pId (Node' NodeContact  txt v []) = node2table uId (Just pId) (Node' NodeContact txt v [])
 275 childWith _   _   (Node' _        _   _ _) = panic "This NodeType can not be a child"
 276
 277
 278 -- =================================================================== --
 279 -- |
 280 -- CorpusDocument is a corpus made from a set of documents
 281 -- CorpusContact  is a corpus made from a set of contacts (syn of Annuaire)
 282 data CorpusType = CorpusDocument | CorpusContact
 283
 284 class MkCorpus a
 285   where
 286     mk :: Maybe Name -> Maybe a -> ParentId -> UserId -> Cmd err [NodeId]
 287
 288 instance MkCorpus HyperdataCorpus
 289   where
 290     mk n Nothing  p u = insertNode NodeCorpus n Nothing p u
 291     mk n (Just h) p u = insertNode NodeCorpus n (Just $ DefaultCorpus h) p u
 292
 293
 294 instance MkCorpus HyperdataAnnuaire
 295   where
 296     mk n Nothing  p u = insertNode NodeCorpus   n Nothing p u
 297     mk n (Just h) p u = insertNode NodeAnnuaire n (Just $ DefaultAnnuaire h) p u
 298
 299
 300 getOrMkList :: HasNodeError err
 301             => ParentId
 302             -> UserId
 303             -> Cmd err ListId
 304 getOrMkList pId uId =
 305   maybe (mkList' pId uId) (pure . view node_id) . headMay =<< getListsWithParentId pId
 306     where
 307       mkList' pId uId = maybe (nodeError MkNode) pure . headMay =<< insertDefaultNode NodeList pId uId
 308
 309 -- | TODO remove defaultList
 310 defaultList :: HasNodeError err => CorpusId -> Cmd err ListId
 311 defaultList cId =
 312   maybe (nodeError NoListFound) (pure . view node_id) . headMay =<< getListsWithParentId cId
 313
 314
 315 getListsWithParentId :: NodeId -> Cmd err [Node HyperdataList]
 316 getListsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeList)
 317