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