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 nodeContactW :: Maybe Name -> Maybe HyperdataContact
 158              -> AnnuaireId -> UserId -> NodeWrite
 159 nodeContactW maybeName maybeContact aId =
 160   node NodeContact name contact (Just aId)
 161     where
 162       name    = maybe "Contact" identity maybeName
 163       contact = maybe arbitraryHyperdataContact identity maybeContact
 164 ------------------------------------------------------------------------
 165 nodeCorpusW :: Maybe Name -> Maybe HyperdataCorpus -> ParentId -> UserId -> NodeWrite
 166 nodeCorpusW maybeName maybeCorpus pId = node NodeCorpus name corpus (Just pId)
 167   where
 168     name   = maybe "Corpus" identity maybeName
 169     corpus = maybe defaultHyperdataCorpus identity maybeCorpus
 170                    --------------------------
 171
 172 nodeDocumentW :: Maybe Name -> Maybe HyperdataDocument -> CorpusId -> UserId -> NodeWrite
 173 nodeDocumentW maybeName maybeDocument cId = node NodeDocument name doc (Just cId)
 174   where
 175     name = maybe "Document" identity maybeName
 176     doc  = maybe defaultHyperdataDocument identity maybeDocument
 177 ------------------------------------------------------------------------
 178 -- | Sugar to insert Node with NodeType in Database
 179 insertDefaultNode :: NodeType -> ParentId -> UserId -> Cmd err [NodeId]
 180 insertDefaultNode nt p u = insertNode nt Nothing Nothing p u
 181
 182 insertNode :: NodeType -> Maybe Name -> Maybe DefaultHyperdata -> ParentId -> UserId -> Cmd err [NodeId]
 183 insertNode nt n h p u = insertNodesR [nodeW nt n h p u]
 184
 185 nodeW :: NodeType -> Maybe Name -> Maybe DefaultHyperdata -> ParentId -> UserId -> NodeWrite
 186 nodeW nt n h p u = node nt n' h' (Just p) u
 187   where
 188     n' = fromMaybe (defaultName nt) n
 189     h' = maybe     (defaultHyperdata nt) identity h
 190
 191 ------------------------------------------------------------------------
 192 node :: (ToJSON a, Hyperdata a)
 193      => NodeType
 194      -> Name
 195      -> a
 196      -> Maybe ParentId
 197      -> UserId
 198      -> NodeWrite
 199 node nodeType name hyperData parentId userId =
 200   Node Nothing
 201        (pgInt4 typeId)
 202        (pgInt4 userId)
 203        (pgNodeId <$> parentId)
 204        (pgStrictText name)
 205        Nothing
 206        (pgJSONB $ cs $ encode hyperData)
 207     where
 208       typeId = nodeTypeId nodeType
 209
 210                   -------------------------------
 211 insertNodes :: [NodeWrite] -> Cmd err Int64
 212 insertNodes ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeTable ns rCount Nothing
 213
 214 insertNodesR :: [NodeWrite] -> Cmd err [NodeId]
 215 insertNodesR ns = mkCmd $ \conn ->
 216   runInsert_ conn (Insert nodeTable ns (rReturning (\(Node i _ _ _ _ _ _) -> i)) Nothing)
 217
 218 insertNodesWithParent :: Maybe ParentId -> [NodeWrite] -> Cmd err Int64
 219 insertNodesWithParent pid ns = insertNodes (set node_parentId (pgNodeId <$> pid) <$> ns)
 220
 221 insertNodesWithParentR :: Maybe ParentId -> [NodeWrite] -> Cmd err [NodeId]
 222 insertNodesWithParentR pid ns = insertNodesR (set node_parentId (pgNodeId <$> pid) <$> ns)
 223 ------------------------------------------------------------------------
 224 -- TODO
 225 -- currently this function removes the child relation
 226 -- needs a Temporary type between Node' and NodeWriteT
 227
 228 node2table :: UserId -> Maybe ParentId -> Node' -> NodeWrite
 229 node2table uid pid (Node' nt txt v []) = Node Nothing (pgInt4 $ nodeTypeId nt) (pgInt4 uid) (fmap pgNodeId pid) (pgStrictText txt) Nothing (pgStrictJSONB $ cs $ encode v)
 230 node2table _ _ (Node' _ _ _ _) = panic "node2table: should not happen, Tree insert not implemented yet"
 231
 232
 233 data Node' = Node' { _n_type :: NodeType
 234                    , _n_name :: Text
 235                    , _n_data :: Value
 236                    , _n_children :: [Node']
 237                    } deriving (Show)
 238
 239 mkNodes :: [NodeWrite] -> Cmd err Int64
 240 mkNodes ns = mkCmd $ \conn -> runInsert_ conn
 241                    $ Insert nodeTable ns rCount Nothing
 242
 243 mkNodeR :: [NodeWrite] -> Cmd err [NodeId]
 244 mkNodeR ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeTable ns (rReturning _node_id) Nothing
 245
 246 ------------------------------------------------------------------------
 247 childWith :: UserId -> ParentId -> Node' -> NodeWrite
 248 childWith uId pId (Node' NodeDocument txt v []) = node2table uId (Just pId) (Node' NodeDocument txt v [])
 249 childWith uId pId (Node' NodeContact  txt v []) = node2table uId (Just pId) (Node' NodeContact txt v [])
 250 childWith _   _   (Node' _        _   _ _) = panic "This NodeType can not be a child"
 251
 252
 253 -- =================================================================== --
 254 -- |
 255 -- CorpusDocument is a corpus made from a set of documents
 256 -- CorpusContact  is a corpus made from a set of contacts (syn of Annuaire)
 257 data CorpusType = CorpusDocument | CorpusContact
 258
 259 class MkCorpus a
 260   where
 261     mk :: Maybe Name -> Maybe a -> ParentId -> UserId -> Cmd err [NodeId]
 262
 263 instance MkCorpus HyperdataCorpus
 264   where
 265     mk n Nothing  p u = insertNode NodeCorpus n Nothing p u
 266     mk n (Just h) p u = insertNode NodeCorpus n (Just $ DefaultCorpus h) p u
 267
 268
 269 instance MkCorpus HyperdataAnnuaire
 270   where
 271     mk n Nothing  p u = insertNode NodeCorpus   n Nothing p u
 272     mk n (Just h) p u = insertNode NodeAnnuaire n (Just $ DefaultAnnuaire h) p u
 273
 274
 275 getOrMkList :: HasNodeError err
 276             => ParentId
 277             -> UserId
 278             -> Cmd err ListId
 279 getOrMkList pId uId =
 280   maybe (mkList' pId uId) (pure . view node_id) . headMay =<< getListsWithParentId pId
 281     where
 282       mkList' pId uId = maybe (nodeError MkNode) pure . headMay =<< insertDefaultNode NodeList pId uId
 283
 284 -- | TODO remove defaultList
 285 defaultList :: HasNodeError err => CorpusId -> Cmd err ListId
 286 defaultList cId =
 287   maybe (nodeError NoListFound) (pure . view node_id) . headMay =<< getListsWithParentId cId
 288
 289
 290 getListsWithParentId :: NodeId -> Cmd err [Node HyperdataList]
 291 getListsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeList)
 292