src/Gargantext/Database/Node.hs

   1 {-|
   2 Module      : Gargantext.Database.Node
   3 Description : Main requests of Node to the database
   4 Copyright   : (c) CNRS, 2017-Present
   5 License     : AGPL + CECILL v3
   6 Maintainer  : team@gargantext.org
   7 Stability   : experimental
   8 Portability : POSIX
   9 -}
  10
  11 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
  12 {-# OPTIONS_GHC -fno-warn-orphans        #-}
  13
  14 {-# LANGUAGE Arrows                 #-}
  15 {-# LANGUAGE DeriveGeneric          #-}
  16 {-# LANGUAGE FlexibleInstances      #-}
  17 {-# LANGUAGE FunctionalDependencies #-}
  18 {-# LANGUAGE MultiParamTypeClasses  #-}
  19 {-# LANGUAGE NoImplicitPrelude      #-}
  20 {-# LANGUAGE TemplateHaskell        #-}
  21
  22 module Gargantext.Database.Node where
  23
  24
  25 import GHC.Int (Int64)
  26 import Data.Maybe
  27 import Data.Time (UTCTime)
  28 import Database.PostgreSQL.Simple.FromField ( Conversion
  29                                             , ResultError(ConversionFailed)
  30                                             , FromField
  31                                             , fromField
  32                                             , returnError
  33                                             )
  34 import Prelude hiding (null, id, map, sum)
  35
  36 import Gargantext.Core.Types
  37 import Gargantext.Database.Types.Node (NodeType)
  38 import Gargantext.Database.Queries
  39 import Gargantext.Database.Config (nodeTypeId)
  40 import Gargantext.Prelude hiding (sum)
  41
  42
  43 import Database.PostgreSQL.Simple.Internal  (Field)
  44 import Control.Arrow (returnA)
  45 import Control.Lens.TH (makeLensesWith, abbreviatedFields)
  46 import Data.Aeson
  47 import Data.Maybe (Maybe, fromMaybe)
  48 import Data.Text (Text, pack)
  49 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
  50 import Data.Typeable (Typeable)
  51
  52 import qualified Data.ByteString      as DB
  53 import qualified Data.ByteString.Lazy as DBL
  54 import Data.ByteString (ByteString)
  55
  56 import Database.PostgreSQL.Simple (Connection)
  57 import Opaleye hiding (FromField)
  58 import Opaleye.Internal.QueryArr (Query)
  59 import qualified Data.Profunctor.Product as PP
  60 -- | Types for Node Database Management
  61 data PGTSVector
  62
  63 ------------------------------------------------------------------------
  64 type CorpusId = Int
  65 ------------------------------------------------------------------------
  66
  67 instance FromField HyperdataCorpus where
  68     fromField = fromField'
  69
  70 instance FromField HyperdataDocument where
  71     fromField = fromField'
  72
  73 instance FromField HyperdataDocumentV3 where
  74     fromField = fromField'
  75
  76 instance FromField HyperdataProject where
  77     fromField = fromField'
  78
  79 instance FromField HyperdataUser where
  80     fromField = fromField'
  81
  82
  83 instance QueryRunnerColumnDefault PGJsonb HyperdataDocument where
  84   queryRunnerColumnDefault = fieldQueryRunnerColumn
  85 instance QueryRunnerColumnDefault PGJsonb HyperdataDocumentV3 where
  86   queryRunnerColumnDefault = fieldQueryRunnerColumn
  87
  88 instance QueryRunnerColumnDefault PGJsonb HyperdataCorpus   where
  89   queryRunnerColumnDefault = fieldQueryRunnerColumn
  90
  91 instance QueryRunnerColumnDefault PGJsonb HyperdataProject  where
  92   queryRunnerColumnDefault = fieldQueryRunnerColumn
  93
  94 instance QueryRunnerColumnDefault PGJsonb HyperdataUser     where
  95   queryRunnerColumnDefault = fieldQueryRunnerColumn
  96
  97
  98
  99 fromField' :: (Typeable b, FromJSON b) => Field -> Maybe DB.ByteString -> Conversion b
 100 fromField' field mb = do
 101     v <- fromField field mb
 102     valueToHyperdata v
 103       where
 104           valueToHyperdata v = case fromJSON v of
 105              Success a  -> pure a
 106              Error _err -> returnError ConversionFailed field "cannot parse hyperdata"
 107
 108
 109 $(makeAdaptorAndInstance "pNode" ''NodePoly)
 110 $(makeLensesWith abbreviatedFields ''NodePoly)
 111
 112
 113 nodeTable :: Table NodeWrite NodeRead
 114 nodeTable = Table "nodes" (pNode Node { node_id                = optional "id"
 115                                         , node_typename        = required "typename"
 116                                         , node_userId          = required "user_id"
 117                                         , node_parentId        = required "parent_id"
 118                                         , node_name            = required "name"
 119                                         , node_date            = optional "date"
 120                                         , node_hyperdata       = required "hyperdata"
 121                      --                   , node_titleAbstract   = optional "title_abstract"
 122                                         }
 123                             )
 124
 125
 126 nodeTable' :: Table (Maybe (Column PGInt4)
 127                     ,       Column PGInt4
 128                     ,       Column PGInt4
 129                     ,       Column PGInt4
 130                     ,       Column PGText
 131                     ,Maybe (Column PGTimestamptz)
 132                     ,       Column PGJsonb
 133                     )
 134                     ((Column PGInt4)
 135                     ,       Column PGInt4
 136                     ,       Column PGInt4
 137                     ,       Column PGInt4
 138                     ,       Column PGText
 139                     ,(Column PGTimestamptz)
 140                     ,       Column PGJsonb
 141                     )
 142
 143 nodeTable' = Table "nodes" (PP.p7 ( optional "id"
 144                                , required "typename"
 145                                , required "user_id"
 146                                , required "parent_id"
 147                                , required "name"
 148                                , optional "date"
 149                                , required "hyperdata"
 150                                )
 151                             )
 152
 153
 154 queryNodeTable :: Query NodeRead
 155 queryNodeTable = queryTable nodeTable
 156
 157
 158 selectNode :: Column PGInt4 -> Query NodeRead
 159 selectNode id = proc () -> do
 160     row <- queryNodeTable -< ()
 161     restrict -< node_id row .== id
 162     returnA -< row
 163
 164 runGetNodes :: Connection -> Query NodeRead -> IO [Node Value]
 165 runGetNodes = runQuery
 166
 167 -- | order by publication date
 168 -- Favorites (Bool), node_ngrams
 169 selectNodesWith :: ParentId     -> Maybe NodeType
 170                 -> Maybe Offset -> Maybe Limit   -> Query NodeRead
 171 selectNodesWith parentId maybeNodeType maybeOffset maybeLimit =
 172         --offset' maybeOffset $ limit' maybeLimit $ orderBy (asc (hyperdataDocument_Publication_date . node_hyperdata)) $ selectNodesWith' parentId typeId
 173         limit' maybeLimit $ offset' maybeOffset $ orderBy (asc node_id) $ selectNodesWith' parentId maybeNodeType
 174
 175 selectNodesWith' :: ParentId -> Maybe NodeType -> Query NodeRead
 176 selectNodesWith' parentId maybeNodeType = proc () -> do
 177     node <- (proc () -> do
 178             row@(Node _ typeId _ parentId' _ _ _) <- queryNodeTable -< ()
 179             restrict -< parentId' .== (toNullable $ pgInt4 parentId)
 180
 181             let typeId' = maybe 0 nodeTypeId maybeNodeType
 182
 183             restrict -< if typeId' > 0
 184                            then typeId   .== (pgInt4 (typeId' :: Int))
 185                            else (pgBool True)
 186             returnA  -< row ) -< ()
 187     returnA -< node
 188
 189
 190
 191 deleteNode :: Connection -> Int -> IO Int
 192 deleteNode conn n = fromIntegral <$> runDelete conn nodeTable
 193                  (\(Node n_id _ _ _ _ _ _) -> n_id .== pgInt4 n)
 194
 195 deleteNodes :: Connection -> [Int] -> IO Int
 196 deleteNodes conn ns = fromIntegral <$> runDelete conn nodeTable
 197                    (\(Node n_id _ _ _ _ _ _) -> in_ ((map pgInt4 ns)) n_id)
 198
 199
 200 getNodesWith :: Connection   -> Int         -> Maybe NodeType
 201              -> Maybe Offset -> Maybe Limit -> IO [Node Value]
 202 getNodesWith conn parentId nodeType maybeOffset maybeLimit =
 203     runQuery conn $ selectNodesWith
 204                   parentId nodeType maybeOffset maybeLimit
 205
 206
 207 -- NP check type
 208 getNodesWithParentId :: Connection -> Int
 209                      -> Maybe Text -> IO [Node Value]
 210 getNodesWithParentId conn n _ = runQuery conn $ selectNodesWithParentID n
 211
 212 getNodesWithParentId' :: Connection -> Int
 213                      -> Maybe Text -> IO [Node Value]
 214 getNodesWithParentId' conn n _ = runQuery conn $ selectNodesWithParentID n
 215
 216
 217 ------------------------------------------------------------------------
 218 getDocumentsV3WithParentId :: Connection -> Int -> IO [Node HyperdataDocumentV3]
 219 getDocumentsV3WithParentId conn n = runQuery conn $ selectNodesWith' n (Just Document)
 220
 221 getDocumentsWithParentId :: Connection -> Int -> IO [Node HyperdataDocument]
 222 getDocumentsWithParentId conn n = runQuery conn $ selectNodesWith' n (Just Document)
 223
 224 ------------------------------------------------------------------------
 225
 226
 227 selectNodesWithParentID :: Int -> Query NodeRead
 228 selectNodesWithParentID n = proc () -> do
 229     row@(Node _ _ _ parent_id _ _ _) <- queryNodeTable -< ()
 230     restrict -< if n > 0
 231                    then
 232                         parent_id .== (toNullable $ pgInt4 n)
 233                    else
 234                         isNull parent_id
 235     returnA -< row
 236
 237
 238 selectNodesWithType :: Column PGInt4 -> Query NodeRead
 239 selectNodesWithType type_id = proc () -> do
 240     row@(Node _ tn _ _ _ _ _) <- queryNodeTable -< ()
 241     restrict -< tn .== type_id
 242     returnA -< row
 243
 244
 245 getNode :: Connection -> Int -> IO (Node Value)
 246 getNode conn id = do
 247     fromMaybe (error $ "Node does node exist: " <> show id) . headMay <$> runQuery conn (limit 1 $ selectNode (pgInt4 id))
 248
 249
 250 getNodesWithType :: Connection -> Column PGInt4 -> IO [Node HyperdataDocument]
 251 getNodesWithType conn type_id = do
 252     runQuery conn $ selectNodesWithType type_id
 253
 254 type UserId = NodeId
 255 type TypeId = Int
 256
 257
 258 ------------------------------------------------------------------------
 259 -- Quick and dirty
 260 ------------------------------------------------------------------------
 261 type NodeWrite' = NodePoly (Maybe Int) Int Int (ParentId) Text (Maybe UTCTime) ByteString
 262
 263 --node :: UserId -> ParentId -> NodeType -> Text -> Value -> NodeWrite'
 264 node :: UserId -> ParentId -> NodeType -> Text -> Value -> NodeWrite'
 265 node userId parentId nodeType name nodeData = Node Nothing typeId userId parentId name Nothing byteData
 266   where
 267     typeId = nodeTypeId nodeType
 268     byteData = DB.pack $ DBL.unpack $ encode nodeData
 269
 270
 271
 272 node2write :: (Functor f2, Functor f1) =>
 273               Int
 274               -> NodePoly (f1 Int) Int Int parentId Text (f2 UTCTime) ByteString
 275               -> (f1 (Column PGInt4), Column PGInt4, Column PGInt4,
 276                   Column PGInt4, Column PGText, f2 (Column PGTimestamptz),
 277                   Column PGJsonb)
 278 node2write pid (Node id tn ud _ nm dt hp) = ((pgInt4    <$> id)
 279                                          ,(pgInt4        tn)
 280                                          ,(pgInt4        ud)
 281                                          ,(pgInt4        pid)
 282                                          ,(pgStrictText  nm)
 283                                          ,(pgUTCTime <$> dt)
 284                                          ,(pgStrictJSONB hp)
 285                                          )
 286
 287
 288 mkNode :: Connection -> ParentId -> [NodeWrite'] -> IO Int64
 289 mkNode conn pid ns = runInsertMany conn nodeTable' $ map (node2write pid) ns
 290
 291 mkNodeR :: Connection -> ParentId -> [NodeWrite'] -> IO [Int]
 292 mkNodeR conn pid ns = runInsertManyReturning conn nodeTable' (map (node2write pid) ns) (\(i,_,_,_,_,_,_) -> i)
 293
 294
 295 ------------------------------------------------------------------------
 296 -- TODO Hierachy of Nodes
 297 -- post and get same types Node' and update if changes
 298
 299 {- TODO semantic to achieve
 300 post c uid pid [ Node' Corpus "name" "{}" []
 301                , Node' Folder "name" "{}" [Node' Corpus "test 2" "" [ Node' Document "title" "metaData" []
 302                                                                     , Node' Document "title" "jsonData" []
 303                                                                     ]
 304                                           ]
 305                ]
 306 -}
 307 ------------------------------------------------------------------------
 308
 309 -- TODO
 310 -- currently this function remove the child relation
 311 -- needs a Temporary type between Node' and NodeWriteT
 312 node2table :: UserId -> ParentId -> Node' -> [NodeWriteT]
 313 node2table uid pid (Node' nt txt v []) = [( Nothing, (pgInt4$ nodeTypeId nt), (pgInt4 uid), (pgInt4 pid)
 314                                          , pgStrictText txt, Nothing, pgStrictJSONB $ DB.pack $ DBL.unpack $ encode v)]
 315 node2table _ _ (Node' _ _ _ _) = panic $ pack "node2table: should not happen, Tree insert not implemented yet"
 316
 317
 318 data Node' = Node' { _n_type :: NodeType
 319                    , _n_name :: Text
 320                    , _n_data :: Value
 321                    , _n_children :: [Node']
 322                    } deriving (Show)
 323
 324
 325 type NodeWriteT =  ( Maybe (Column PGInt4)
 326                    , Column PGInt4, Column PGInt4
 327                    , Column PGInt4, Column PGText
 328                    , Maybe (Column PGTimestamptz)
 329                    , Column PGJsonb
 330                    )
 331
 332
 333 mkNode' :: Connection -> [NodeWriteT] -> IO Int64
 334 mkNode' conn ns = runInsertMany conn nodeTable' ns
 335
 336 mkNodeR' :: Connection -> [NodeWriteT] -> IO [Int]
 337 mkNodeR' conn ns = runInsertManyReturning conn nodeTable' ns (\(i,_,_,_,_,_,_) -> i)
 338
 339 -- | postNode
 340 postNode :: Connection -> UserId -> ParentId -> Node' -> IO [Int]
 341 postNode c uid pid (Node' nt txt v []) = mkNodeR' c (node2table uid pid (Node' nt txt v []))
 342
 343 postNode c uid pid (Node' NodeCorpus txt v ns) = do
 344   [pid']  <- postNode c uid pid (Node' NodeCorpus txt v [])
 345   pids    <- mkNodeR' c $ concat $ map (\n -> childWith uid pid' n) ns
 346   pure (pids)
 347
 348 postNode c uid pid (Node' Annuaire txt v ns) = do
 349   [pid']  <- postNode c uid pid (Node' Annuaire txt v [])
 350   pids    <- mkNodeR' c $ concat $ map (\n -> childWith uid pid' n) ns
 351   pure (pids)
 352 postNode _ _ _ (Node' _ _ _ _) = panic $ pack "postNode for this type not implemented yet"
 353
 354
 355 childWith :: UserId -> ParentId -> Node' -> [NodeWriteT]
 356 childWith uId pId (Node' Document txt v []) = node2table uId pId (Node' Document txt v [])
 357 childWith uId pId (Node' UserPage txt v []) = node2table uId pId (Node' UserPage txt v [])
 358 childWith _   _   (Node' _        _   _ _) = panic $ pack "This NodeType can not be a child"
 359