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, JSONB 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
 158 ------------------------------------------------------------------------
 159 -- | Example of use:
 160 -- runCmdReplEasy  (getNodesWithType NodeList (Proxy :: Proxy HyperdataList))
 161 getNodesWithType :: (HasNodeError err, JSONB a) => NodeType -> proxy a -> Cmd err [Node a]
 162 getNodesWithType nt _ = runOpaQuery $ selectNodesWithType nt
 163
 164 selectNodesWithType :: NodeType -> Query NodeRead
 165 selectNodesWithType nt = proc () -> do
 166     row@(Node _ _ tn _ _ _ _ _) <- queryNodeTable -< ()
 167     restrict -< tn .== (pgInt4 $ nodeTypeId nt)
 168     returnA -< row
 169
 170 ------------------------------------------------------------------------
 171
 172
 173 getNode :: HasNodeError err => NodeId -> Cmd err (Node Value)
 174 getNode nId = do
 175   maybeNode <- headMay <$> runOpaQuery (selectNode (pgNodeId nId))
 176   case maybeNode of
 177     Nothing -> nodeError (DoesNotExist nId)
 178     Just  r -> pure r
 179
 180 getNodeWith :: (HasNodeError err, JSONB a)
 181             => NodeId -> proxy a -> Cmd err (Node a)
 182 getNodeWith nId _ = do
 183   maybeNode <- headMay <$> runOpaQuery (selectNode (pgNodeId nId))
 184   case maybeNode of
 185     Nothing -> nodeError (DoesNotExist nId)
 186     Just  r -> pure r
 187
 188
 189 ------------------------------------------------------------------------
 190 -- | Sugar to insert Node with NodeType in Database
 191 insertDefaultNode :: NodeType -> ParentId -> UserId -> Cmd err [NodeId]
 192 insertDefaultNode nt p u = insertNode nt Nothing Nothing p u
 193
 194 insertNode :: NodeType -> Maybe Name -> Maybe DefaultHyperdata -> ParentId -> UserId -> Cmd err [NodeId]
 195 insertNode nt n h p u = insertNodesR [nodeW nt n h p u]
 196
 197 nodeW :: NodeType -> Maybe Name -> Maybe DefaultHyperdata -> ParentId -> UserId -> NodeWrite
 198 nodeW nt n h p u = node nt n' h' (Just p) u
 199   where
 200     n' = fromMaybe (defaultName nt) n
 201     h' = maybe     (defaultHyperdata nt) identity h
 202
 203 ------------------------------------------------------------------------
 204 node :: (ToJSON a, Hyperdata a)
 205      => NodeType
 206      -> Name
 207      -> a
 208      -> Maybe ParentId
 209      -> UserId
 210      -> NodeWrite
 211 node nodeType name hyperData parentId userId =
 212   Node Nothing Nothing
 213        (pgInt4 typeId)
 214        (pgInt4 userId)
 215        (pgNodeId <$> parentId)
 216        (pgStrictText name)
 217        Nothing
 218        (pgJSONB $ cs $ encode hyperData)
 219     where
 220       typeId = nodeTypeId nodeType
 221
 222                   -------------------------------
 223 insertNodes :: [NodeWrite] -> Cmd err Int64
 224 insertNodes ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeTable ns rCount Nothing
 225
 226 {-
 227 insertNodes' :: [Node a] -> Cmd err Int64
 228 insertNodes' ns = mkCmd $ \conn -> runInsert_ conn
 229                         $ Insert nodeTable ns' rCount Nothing
 230   where
 231     ns' :: [NodeWrite]
 232     ns' = map (\(Node i t u p n d h)
 233                 -> Node (pgNodeId          <$> i)
 234                         (pgInt4 $ nodeTypeId   t)
 235                         (pgInt4                u)
 236                         (pgNodeId          <$> p)
 237                         (pgStrictText          n)
 238                         (pgUTCTime         <$> d)
 239                         (pgJSONB $ cs $ encode h)
 240               ) ns
 241 -}
 242
 243 insertNodesR :: [NodeWrite] -> Cmd err [NodeId]
 244 insertNodesR ns = mkCmd $ \conn ->
 245   runInsert_ conn (Insert nodeTable ns (rReturning (\(Node i _ _ _ _ _ _ _) -> i)) Nothing)
 246
 247 insertNodesWithParent :: Maybe ParentId -> [NodeWrite] -> Cmd err Int64
 248 insertNodesWithParent pid ns = insertNodes (set node_parentId (pgNodeId <$> pid) <$> ns)
 249
 250 insertNodesWithParentR :: Maybe ParentId -> [NodeWrite] -> Cmd err [NodeId]
 251 insertNodesWithParentR pid ns = insertNodesR (set node_parentId (pgNodeId <$> pid) <$> ns)
 252 ------------------------------------------------------------------------
 253 -- TODO
 254 -- currently this function removes the child relation
 255 -- needs a Temporary type between Node' and NodeWriteT
 256
 257 node2table :: UserId -> Maybe ParentId -> Node' -> NodeWrite
 258 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)
 259 node2table _ _ (Node' _ _ _ _) = panic "node2table: should not happen, Tree insert not implemented yet"
 260
 261
 262 data Node' = Node' { _n_type :: NodeType
 263                    , _n_name :: Text
 264                    , _n_data :: Value
 265                    , _n_children :: [Node']
 266                    } deriving (Show)
 267
 268 mkNodes :: [NodeWrite] -> Cmd err Int64
 269 mkNodes ns = mkCmd $ \conn -> runInsert_ conn
 270                    $ Insert nodeTable ns rCount Nothing
 271
 272 mkNodeR :: [NodeWrite] -> Cmd err [NodeId]
 273 mkNodeR ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeTable ns (rReturning _node_id) Nothing
 274
 275 ------------------------------------------------------------------------
 276 childWith :: UserId -> ParentId -> Node' -> NodeWrite
 277 childWith uId pId (Node' NodeDocument txt v []) = node2table uId (Just pId) (Node' NodeDocument txt v [])
 278 childWith uId pId (Node' NodeContact  txt v []) = node2table uId (Just pId) (Node' NodeContact txt v [])
 279 childWith _   _   (Node' _        _   _ _) = panic "This NodeType can not be a child"
 280
 281
 282 -- =================================================================== --
 283 -- |
 284 -- CorpusDocument is a corpus made from a set of documents
 285 -- CorpusContact  is a corpus made from a set of contacts (syn of Annuaire)
 286 data CorpusType = CorpusDocument | CorpusContact
 287
 288 class MkCorpus a
 289   where
 290     mk :: Maybe Name -> Maybe a -> ParentId -> UserId -> Cmd err [NodeId]
 291
 292 instance MkCorpus HyperdataCorpus
 293   where
 294     mk n Nothing  p u = insertNode NodeCorpus n Nothing p u
 295     mk n (Just h) p u = insertNode NodeCorpus n (Just $ DefaultCorpus h) p u
 296
 297
 298 instance MkCorpus HyperdataAnnuaire
 299   where
 300     mk n Nothing  p u = insertNode NodeCorpus   n Nothing p u
 301     mk n (Just h) p u = insertNode NodeAnnuaire n (Just $ DefaultAnnuaire h) p u
 302
 303
 304 getOrMkList :: HasNodeError err
 305             => ParentId
 306             -> UserId
 307             -> Cmd err ListId
 308 getOrMkList pId uId =
 309   maybe (mkList' pId uId) (pure . view node_id) . headMay =<< getListsWithParentId pId
 310     where
 311       mkList' pId uId = maybe (nodeError MkNode) pure . headMay =<< insertDefaultNode NodeList pId uId
 312
 313 -- | TODO remove defaultList
 314 defaultList :: HasNodeError err => CorpusId -> Cmd err ListId
 315 defaultList cId =
 316   maybe (nodeError NoListFound) (pure . view node_id) . headMay =<< getListsWithParentId cId
 317
 318
 319 getListsWithParentId :: NodeId -> Cmd err [Node HyperdataList]
 320 getListsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeList)
 321