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