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