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 -- insertNodes' :: [Node a] -> Cmd err Int64
 194 insertNodes' ns = mkCmd $ \conn -> runInsert_ conn
 195                         $ Insert nodeTable ns' rCount Nothing
 196   where
 197     ns' :: [NodeWrite]
 198     ns' = map (\(Node i t u p n d h)
 199                 -> Node (pgNodeId          <$> i)
 200                         (pgInt4 $ nodeTypeId   t)
 201                         (pgInt4                u)
 202                         (pgNodeId          <$> p)
 203                         (pgStrictText          n)
 204                         (pgUTCTime         <$> d)
 205                         (pgJSONB $ cs $ encode h)
 206               ) ns
 207
 208
 209 insertNodesR :: [NodeWrite] -> Cmd err [NodeId]
 210 insertNodesR ns = mkCmd $ \conn ->
 211   runInsert_ conn (Insert nodeTable ns (rReturning (\(Node i _ _ _ _ _ _) -> i)) Nothing)
 212
 213 insertNodesWithParent :: Maybe ParentId -> [NodeWrite] -> Cmd err Int64
 214 insertNodesWithParent pid ns = insertNodes (set node_parentId (pgNodeId <$> pid) <$> ns)
 215
 216 insertNodesWithParentR :: Maybe ParentId -> [NodeWrite] -> Cmd err [NodeId]
 217 insertNodesWithParentR pid ns = insertNodesR (set node_parentId (pgNodeId <$> pid) <$> ns)
 218 ------------------------------------------------------------------------
 219 -- TODO
 220 -- currently this function removes the child relation
 221 -- needs a Temporary type between Node' and NodeWriteT
 222
 223 node2table :: UserId -> Maybe ParentId -> Node' -> NodeWrite
 224 node2table uid pid (Node' nt txt v []) = Node Nothing (pgInt4 $ nodeTypeId nt) (pgInt4 uid) (fmap pgNodeId pid) (pgStrictText txt) Nothing (pgStrictJSONB $ cs $ encode v)
 225 node2table _ _ (Node' _ _ _ _) = panic "node2table: should not happen, Tree insert not implemented yet"
 226
 227
 228 data Node' = Node' { _n_type :: NodeType
 229                    , _n_name :: Text
 230                    , _n_data :: Value
 231                    , _n_children :: [Node']
 232                    } deriving (Show)
 233
 234 mkNodes :: [NodeWrite] -> Cmd err Int64
 235 mkNodes ns = mkCmd $ \conn -> runInsert_ conn
 236                    $ Insert nodeTable ns rCount Nothing
 237
 238 mkNodeR :: [NodeWrite] -> Cmd err [NodeId]
 239 mkNodeR ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeTable ns (rReturning _node_id) Nothing
 240
 241 ------------------------------------------------------------------------
 242 childWith :: UserId -> ParentId -> Node' -> NodeWrite
 243 childWith uId pId (Node' NodeDocument txt v []) = node2table uId (Just pId) (Node' NodeDocument txt v [])
 244 childWith uId pId (Node' NodeContact  txt v []) = node2table uId (Just pId) (Node' NodeContact txt v [])
 245 childWith _   _   (Node' _        _   _ _) = panic "This NodeType can not be a child"
 246
 247
 248 -- =================================================================== --
 249 -- |
 250 -- CorpusDocument is a corpus made from a set of documents
 251 -- CorpusContact  is a corpus made from a set of contacts (syn of Annuaire)
 252 data CorpusType = CorpusDocument | CorpusContact
 253
 254 class MkCorpus a
 255   where
 256     mk :: Maybe Name -> Maybe a -> ParentId -> UserId -> Cmd err [NodeId]
 257
 258 instance MkCorpus HyperdataCorpus
 259   where
 260     mk n Nothing  p u = insertNode NodeCorpus n Nothing p u
 261     mk n (Just h) p u = insertNode NodeCorpus n (Just $ DefaultCorpus h) p u
 262
 263
 264 instance MkCorpus HyperdataAnnuaire
 265   where
 266     mk n Nothing  p u = insertNode NodeCorpus   n Nothing p u
 267     mk n (Just h) p u = insertNode NodeAnnuaire n (Just $ DefaultAnnuaire h) p u
 268
 269
 270 getOrMkList :: HasNodeError err
 271             => ParentId
 272             -> UserId
 273             -> Cmd err ListId
 274 getOrMkList pId uId =
 275   maybe (mkList' pId uId) (pure . view node_id) . headMay =<< getListsWithParentId pId
 276     where
 277       mkList' pId uId = maybe (nodeError MkNode) pure . headMay =<< insertDefaultNode NodeList pId uId
 278
 279 -- | TODO remove defaultList
 280 defaultList :: HasNodeError err => CorpusId -> Cmd err ListId
 281 defaultList cId =
 282   maybe (nodeError NoListFound) (pure . view node_id) . headMay =<< getListsWithParentId cId
 283
 284
 285 getListsWithParentId :: NodeId -> Cmd err [Node HyperdataList]
 286 getListsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeList)
 287