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 ------------------------------------------------------------------------
 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