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