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