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