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 import Data.Text (pack)
  27 import GHC.Int (Int64)
  28 import Control.Lens (set)
  29 import Data.Maybe
  30 import Data.Time (UTCTime)
  31 import Database.PostgreSQL.Simple.FromField ( Conversion
  32                                             , ResultError(ConversionFailed)
  33                                             , FromField
  34                                             , fromField
  35                                             , returnError
  36                                             )
  37 import Prelude hiding (null, id, map, sum)
  38
  39 import Gargantext.Core (Lang(..))
  40 import Gargantext.Core.Types
  41 import Gargantext.Database.Types.Node (NodeType)
  42 import Gargantext.Database.Queries
  43 import Gargantext.Database.Config (nodeTypeId)
  44 import Gargantext.Prelude hiding (sum)
  45
  46 import Database.PostgreSQL.Simple.Internal  (Field)
  47 import Control.Applicative (Applicative)
  48 import Control.Arrow (returnA)
  49 import Control.Lens.TH (makeLensesWith, abbreviatedFields)
  50 import Control.Monad.IO.Class
  51 import Control.Monad.Reader
  52 import Data.Aeson
  53 import Data.Maybe (Maybe, fromMaybe)
  54 import Data.Text (Text)
  55 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
  56 import Data.Typeable (Typeable)
  57
  58 import qualified Data.ByteString      as DB
  59 import qualified Data.ByteString.Lazy as DBL
  60 import Data.ByteString (ByteString)
  61
  62 import Database.PostgreSQL.Simple (Connection)
  63 import Opaleye hiding (FromField)
  64 import Opaleye.Internal.QueryArr (Query)
  65 import qualified Data.Profunctor.Product as PP
  66
  67 ------------------------------------------------------------------------
  68 {- | Reader Monad reinvented here:
  69
  70 newtype Cmd a = Cmd { unCmd :: Connection -> IO a }
  71
  72 instance Monad Cmd where
  73   return a = Cmd $ \_ -> return a
  74
  75   m >>= f = Cmd $ \c -> do
  76     a <- unCmd m c
  77     unCmd (f a) c
  78 -}
  79 newtype Cmd a = Cmd (ReaderT Connection IO a)
  80   deriving (Functor, Applicative, Monad, MonadReader Connection, MonadIO)
  81
  82 runCmd :: Connection -> Cmd a -> IO a
  83 runCmd c (Cmd f) = runReaderT f c
  84
  85 mkCmd :: (Connection -> IO a) -> Cmd a
  86 mkCmd = Cmd . ReaderT
  87
  88 ------------------------------------------------------------------------
  89 type CorpusId = Int
  90 type AnnuaireId = Int
  91 type UserId = NodeId
  92 type TypeId = Int
  93 ------------------------------------------------------------------------
  94 instance FromField HyperdataCorpus where
  95     fromField = fromField'
  96
  97 instance FromField HyperdataDocument where
  98     fromField = fromField'
  99
 100 instance FromField HyperdataDocumentV3 where
 101     fromField = fromField'
 102
 103 instance FromField HyperdataUser where
 104     fromField = fromField'
 105 ------------------------------------------------------------------------
 106 instance QueryRunnerColumnDefault PGJsonb HyperdataDocument where
 107   queryRunnerColumnDefault = fieldQueryRunnerColumn
 108
 109 instance QueryRunnerColumnDefault PGJsonb HyperdataDocumentV3 where
 110   queryRunnerColumnDefault = fieldQueryRunnerColumn
 111
 112 instance QueryRunnerColumnDefault PGJsonb HyperdataCorpus   where
 113   queryRunnerColumnDefault = fieldQueryRunnerColumn
 114
 115 instance QueryRunnerColumnDefault PGJsonb HyperdataUser     where
 116   queryRunnerColumnDefault = fieldQueryRunnerColumn
 117 ------------------------------------------------------------------------
 118
 119 fromField' :: (Typeable b, FromJSON b) => Field -> Maybe DB.ByteString -> Conversion b
 120 fromField' field mb = do
 121     v <- fromField field mb
 122     valueToHyperdata v
 123       where
 124           valueToHyperdata v = case fromJSON v of
 125              Success a  -> pure a
 126              Error _err -> returnError ConversionFailed field "cannot parse hyperdata"
 127
 128
 129 $(makeAdaptorAndInstance "pNode" ''NodePoly)
 130 $(makeLensesWith abbreviatedFields ''NodePoly)
 131
 132
 133 nodeTable :: Table NodeWrite NodeRead
 134 nodeTable = Table "nodes" (pNode Node { _node_id                = optional "id"
 135                                         , _node_typename        = required "typename"
 136                                         , _node_userId          = required "user_id"
 137                                         , _node_parentId        = required "parent_id"
 138                                         , _node_name            = required "name"
 139                                         , _node_date            = optional "date"
 140                                         , _node_hyperdata       = required "hyperdata"
 141                      --                   , node_titleAbstract   = optional "title_abstract"
 142                                         }
 143                             )
 144
 145
 146 nodeTable' :: Table (Maybe (Column PGInt4)
 147                     ,       Column PGInt4
 148                     ,       Column PGInt4
 149                     ,Maybe (Column PGInt4)
 150                     ,       Column PGText
 151                     ,Maybe (Column PGTimestamptz)
 152                     ,       Column PGJsonb
 153                     )
 154                     ((Column PGInt4)
 155                     ,       Column PGInt4
 156                     ,       Column PGInt4
 157                     ,       Column PGInt4
 158                     ,       Column PGText
 159                     ,(Column PGTimestamptz)
 160                     ,       Column PGJsonb
 161                     )
 162
 163 nodeTable' = Table "nodes" (PP.p7 ( optional "id"
 164                                , required "typename"
 165                                , required "user_id"
 166                                , optional "parent_id"
 167                                , required "name"
 168                                , optional "date"
 169                                , required "hyperdata"
 170                                )
 171                             )
 172
 173
 174 queryNodeTable :: Query NodeRead
 175 queryNodeTable = queryTable nodeTable
 176
 177 selectNode :: Column PGInt4 -> Query NodeRead
 178 selectNode id = proc () -> do
 179     row <- queryNodeTable -< ()
 180     restrict -< _node_id row .== id
 181     returnA -< row
 182
 183 runGetNodes :: Query NodeRead -> Cmd [Node Value]
 184 runGetNodes q = mkCmd $ \conn -> runQuery conn q
 185
 186 ------------------------------------------------------------------------
 187 selectRootUser :: UserId -> Query NodeRead
 188 selectRootUser userId = proc () -> do
 189     row <- queryNodeTable -< ()
 190     restrict -< _node_userId   row .== (pgInt4 userId)
 191     restrict -< _node_typename row .== (pgInt4 $ nodeTypeId NodeUser)
 192     returnA -< row
 193
 194 getRoot :: UserId -> Cmd [Node HyperdataUser]
 195 getRoot userId = mkCmd $ \conn -> runQuery conn (selectRootUser userId)
 196 ------------------------------------------------------------------------
 197
 198 -- | order by publication date
 199 -- Favorites (Bool), node_ngrams
 200 selectNodesWith :: ParentId     -> Maybe NodeType
 201                 -> Maybe Offset -> Maybe Limit   -> Query NodeRead
 202 selectNodesWith parentId maybeNodeType maybeOffset maybeLimit =
 203         --offset' maybeOffset $ limit' maybeLimit $ orderBy (asc (hyperdataDocument_Publication_date . node_hyperdata)) $ selectNodesWith' parentId typeId
 204         limit' maybeLimit $ offset' maybeOffset $ orderBy (asc _node_id) $ selectNodesWith' parentId maybeNodeType
 205
 206 selectNodesWith' :: ParentId -> Maybe NodeType -> Query NodeRead
 207 selectNodesWith' parentId maybeNodeType = proc () -> do
 208     node <- (proc () -> do
 209             row@(Node _ typeId _ parentId' _ _ _) <- queryNodeTable -< ()
 210             restrict -< parentId' .== (toNullable $ pgInt4 parentId)
 211
 212             let typeId' = maybe 0 nodeTypeId maybeNodeType
 213
 214             restrict -< if typeId' > 0
 215                            then typeId   .== (pgInt4 (typeId' :: Int))
 216                            else (pgBool True)
 217             returnA  -< row ) -< ()
 218     returnA -< node
 219
 220
 221 --type Cmd' a = forall m. (MonadReader env m, HasConnection env, MonadIO m) => m a
 222
 223
 224 -- deleteNode :: (MonadReader Connection m, MonadIO m) => Int -> m Int
 225 -- deleteNode :: Int -> Cmd' Int
 226
 227 deleteNode :: Int -> Cmd Int
 228 deleteNode n = mkCmd $ \conn ->
 229   fromIntegral <$> runDelete conn nodeTable
 230                  (\(Node n_id _ _ _ _ _ _) -> n_id .== pgInt4 n)
 231
 232 deleteNodes :: [Int] -> Cmd Int
 233 deleteNodes ns = mkCmd $ \conn ->
 234   fromIntegral <$> runDelete conn nodeTable
 235                    (\(Node n_id _ _ _ _ _ _) -> in_ ((map pgInt4 ns)) n_id)
 236
 237
 238 getNodesWith :: Connection   -> Int         -> Maybe NodeType
 239              -> Maybe Offset -> Maybe Limit -> IO [Node Value]
 240 getNodesWith conn parentId nodeType maybeOffset maybeLimit =
 241     runQuery conn $ selectNodesWith
 242                   parentId nodeType maybeOffset maybeLimit
 243
 244
 245 -- NP check type
 246 getNodesWithParentId :: Int
 247                      -> Maybe Text -> Connection -> IO [Node Value]
 248 getNodesWithParentId n _ conn = runQuery conn $ selectNodesWithParentID n
 249
 250 getNodesWithParentId' :: Int
 251                      -> Maybe Text -> Connection -> IO [Node Value]
 252 getNodesWithParentId' n _ conn = runQuery conn $ selectNodesWithParentID n
 253
 254
 255 ------------------------------------------------------------------------
 256 getDocumentsV3WithParentId :: Connection -> Int -> IO [Node HyperdataDocumentV3]
 257 getDocumentsV3WithParentId conn n = runQuery conn $ selectNodesWith' n (Just NodeDocument)
 258
 259 getDocumentsWithParentId :: Connection -> Int -> IO [Node HyperdataDocument]
 260 getDocumentsWithParentId conn n = runQuery conn $ selectNodesWith' n (Just NodeDocument)
 261
 262 ------------------------------------------------------------------------
 263
 264
 265 selectNodesWithParentID :: Int -> Query NodeRead
 266 selectNodesWithParentID n = proc () -> do
 267     row@(Node _ _ _ parent_id _ _ _) <- queryNodeTable -< ()
 268     restrict -< if n > 0
 269                    then
 270                         parent_id .== (toNullable $ pgInt4 n)
 271                    else
 272                         isNull parent_id
 273     returnA -< row
 274
 275
 276 selectNodesWithType :: Column PGInt4 -> Query NodeRead
 277 selectNodesWithType type_id = proc () -> do
 278     row@(Node _ tn _ _ _ _ _) <- queryNodeTable -< ()
 279     restrict -< tn .== type_id
 280     returnA -< row
 281
 282
 283 getNode :: Connection -> Int -> IO (Node Value)
 284 getNode conn id = do
 285     fromMaybe (error $ "Node does node exist: " <> show id) . headMay <$> runQuery conn (limit 1 $ selectNode (pgInt4 id))
 286
 287
 288 getNodesWithType :: Connection -> Column PGInt4 -> IO [Node HyperdataDocument]
 289 getNodesWithType conn type_id = do
 290     runQuery conn $ selectNodesWithType type_id
 291
 292
 293 ------------------------------------------------------------------------
 294 -- WIP
 295 -- TODO Classe HasDefault where
 296 -- default NodeType = Hyperdata
 297 ------------------------------------------------------------------------
 298 type NodeWrite' = NodePoly (Maybe Int) Int Int (Maybe ParentId) Text (Maybe UTCTime) ByteString
 299 ------------------------------------------------------------------------
 300 defaultUser :: HyperdataUser
 301 defaultUser = HyperdataUser (Just $ (pack . show) EN)
 302
 303 nodeUserW :: Maybe Name -> Maybe HyperdataUser -> UserId -> NodeWrite'
 304 nodeUserW maybeName maybeHyperdata = node NodeUser name (Hyperdata user) Nothing
 305   where
 306     name = maybe "User" identity maybeName
 307     user = maybe defaultUser identity maybeHyperdata
 308 ------------------------------------------------------------------------
 309 defaultFolder :: HyperdataFolder
 310 defaultFolder = HyperdataFolder (Just "Markdown Description")
 311
 312 nodeFolderW :: Maybe Name -> Maybe HyperdataFolder -> ParentId -> UserId -> NodeWrite'
 313 nodeFolderW maybeName maybeFolder pid = node NodeFolder name (Hyperdata folder) (Just pid)
 314   where
 315     name   = maybe "Folder" identity maybeName
 316     folder = maybe defaultFolder identity maybeFolder
 317 ------------------------------------------------------------------------
 318 defaultCorpus :: HyperdataCorpus
 319 defaultCorpus = (HyperdataCorpus (Just "Title") (Just "Descr") (Just "Bool query") (Just "Authors") Nothing)
 320
 321 nodeCorpusW :: Maybe Name -> Maybe HyperdataCorpus -> ParentId -> UserId -> NodeWrite'
 322 nodeCorpusW maybeName maybeCorpus pId = node NodeCorpus name (Hyperdata corpus) (Just pId)
 323   where
 324     name   = maybe "Corpus" identity maybeName
 325     corpus = maybe defaultCorpus identity maybeCorpus
 326                    --------------------------
 327 defaultDocument :: HyperdataDocument
 328 defaultDocument = hyperdataDocument
 329
 330 nodeDocumentW :: Maybe Name -> Maybe HyperdataDocument -> CorpusId -> UserId -> NodeWrite'
 331 nodeDocumentW maybeName maybeDocument cId = node NodeDocument name (Hyperdata doc) (Just cId)
 332   where
 333     name = maybe "Document" identity maybeName
 334     doc  = maybe defaultDocument identity maybeDocument
 335 ------------------------------------------------------------------------
 336 defaultAnnuaire :: HyperdataAnnuaire
 337 defaultAnnuaire = HyperdataAnnuaire (Just "Title") (Just "Description")
 338
 339 nodeAnnuaireW :: Maybe Name -> Maybe HyperdataAnnuaire -> ParentId -> UserId -> NodeWrite'
 340 nodeAnnuaireW maybeName maybeAnnuaire pId = node NodeAnnuaire name (Hyperdata annuaire) (Just pId)
 341   where
 342     name     = maybe "Annuaire" identity maybeName
 343     annuaire = maybe defaultAnnuaire identity maybeAnnuaire
 344                    --------------------------
 345 defaultContact :: HyperdataContact
 346 defaultContact = HyperdataContact (Just "Name") (Just "email@here")
 347
 348 nodeContactW :: Maybe Name -> Maybe HyperdataContact -> AnnuaireId -> UserId -> NodeWrite'
 349 nodeContactW maybeName maybeContact aId = node NodeContact name (Hyperdata contact) (Just aId)
 350   where
 351     name    = maybe "Contact" identity maybeName
 352     contact = maybe defaultContact identity maybeContact
 353 ------------------------------------------------------------------------
 354 ------------------------------------------------------------------------
 355 node :: ToJSON a => NodeType -> Name -> Hyperdata a -> Maybe ParentId -> UserId -> NodeWrite'
 356 node nodeType name hyperData parentId userId = Node Nothing typeId userId parentId name Nothing byteData
 357   where
 358     typeId = nodeTypeId nodeType
 359     byteData = DB.pack $ DBL.unpack $ encode $ unHyperdata hyperData
 360
 361                   -------------------------------
 362 node2row :: (Functor maybe1, Functor maybe2, Functor maybe3) =>
 363               NodePoly (maybe2 Int)                      Int            Int  (maybe1           Int)
 364                                 Text        (maybe3 UTCTime)             ByteString
 365                     -> (maybe2 (Column PGInt4), Column PGInt4, Column PGInt4, maybe1 (Column PGInt4)
 366                      , Column PGText, maybe3 (Column PGTimestamptz), Column PGJsonb)
 367 node2row (Node id tn ud pid nm dt hp) = ((pgInt4    <$> id)
 368                                         ,(pgInt4        tn)
 369                                         ,(pgInt4        ud)
 370                                         ,(pgInt4   <$> pid)
 371                                         ,(pgStrictText  nm)
 372                                         ,(pgUTCTime <$> dt)
 373                                         ,(pgStrictJSONB hp)
 374                                         )
 375 ------------------------------------------------------------------------
 376 insertNodesR' :: [NodeWrite'] -> Cmd [Int]
 377 insertNodesR' ns = mkCmd $ \c -> insertNodesR ns c
 378
 379 insertNodes :: [NodeWrite'] -> Connection -> IO Int64
 380 insertNodes ns conn = runInsertMany conn nodeTable' (map node2row ns)
 381
 382 insertNodesR :: [NodeWrite'] -> Connection -> IO [Int]
 383 insertNodesR ns conn = runInsertManyReturning conn nodeTable' (map node2row ns) (\(i,_,_,_,_,_,_) -> i)
 384                        -------------------------
 385 insertNodesWithParent :: Maybe ParentId -> [NodeWrite'] -> Connection -> IO Int64
 386 insertNodesWithParent pid ns conn = insertNodes (map (set node_parentId pid) ns) conn
 387
 388 insertNodesWithParentR :: Maybe ParentId -> [NodeWrite'] -> Connection -> IO [Int]
 389 insertNodesWithParentR pid ns conn = insertNodesR (map (set node_parentId pid) ns) conn
 390 ------------------------------------------------------------------------
 391 -- TODO Hierachy of Nodes
 392 -- post and get same types Node' and update if changes
 393
 394 {- TODO semantic to achieve
 395 post c uid pid [ Node' NodeCorpus "name" "{}" []
 396                , Node' NodeFolder "name" "{}" [Node' NodeCorpus "test 2" "" [ Node' NodeDocument "title" "metaData" []
 397                                                                     , Node' NodeDocument "title" "jsonData" []
 398                                                                     ]
 399                                           ]
 400                ]
 401 -}
 402 ------------------------------------------------------------------------
 403
 404 -- TODO
 405 -- currently this function remove the child relation
 406 -- needs a Temporary type between Node' and NodeWriteT
 407 node2table :: UserId -> Maybe ParentId -> Node' -> NodeWriteT
 408 node2table uid pid (Node' nt txt v []) = ( Nothing, (pgInt4$ nodeTypeId nt), (pgInt4 uid), (fmap pgInt4 pid)
 409                                          , pgStrictText txt, Nothing, pgStrictJSONB $ DB.pack $ DBL.unpack $ encode v)
 410 node2table _ _ (Node' _ _ _ _) = panic "node2table: should not happen, Tree insert not implemented yet"
 411
 412
 413 data Node' = Node' { _n_type :: NodeType
 414                    , _n_name :: Text
 415                    , _n_data :: Value
 416                    , _n_children :: [Node']
 417                    } deriving (Show)
 418
 419
 420 type NodeWriteT =  ( Maybe (Column PGInt4)
 421                    ,        Column PGInt4
 422                    ,        Column PGInt4
 423                    , Maybe (Column PGInt4)
 424                    ,        Column PGText
 425                    , Maybe (Column PGTimestamptz)
 426                    ,        Column PGJsonb
 427                    )
 428
 429
 430 mkNode' :: [NodeWriteT] -> Cmd Int64
 431 mkNode' ns = mkCmd $ \conn -> runInsertMany conn nodeTable' ns
 432
 433 mkNodeR' :: [NodeWriteT] -> Cmd [Int]
 434 mkNodeR' ns = mkCmd $ \conn -> runInsertManyReturning conn nodeTable' ns (\(i,_,_,_,_,_,_) -> i)
 435
 436
 437 ------------------------------------------------------------------------
 438
 439 data NewNode = NewNode { _newNodeId :: Int
 440                        , _newNodeChildren :: [Int] }
 441
 442 -- | postNode
 443 postNode :: UserId -> Maybe ParentId -> Node' -> Cmd NewNode
 444 postNode uid pid (Node' nt txt v []) = do
 445   pids <- mkNodeR' [node2table uid pid (Node' nt txt v [])]
 446   case pids of
 447     [pid] -> pure $ NewNode pid []
 448     _ -> panic "postNode: only one pid expected"
 449
 450 postNode uid pid (Node' NodeCorpus txt v ns) = do
 451   NewNode pid' _ <- postNode uid pid (Node' NodeCorpus txt v [])
 452   pids  <- mkNodeR' (concat $ map (\n -> [childWith uid pid' n]) ns)
 453   pure $ NewNode pid' pids
 454
 455 postNode uid pid (Node' NodeAnnuaire txt v ns) = do
 456   NewNode pid' _ <- postNode uid pid (Node' NodeAnnuaire txt v [])
 457   pids  <- mkNodeR' (concat $ map (\n -> [childWith uid pid' n]) ns)
 458   pure $ NewNode pid' pids
 459 postNode _ _ (Node' _ _ _ _) = panic "TODO: postNode for this type not implemented yet"
 460
 461
 462 childWith :: UserId -> ParentId -> Node' -> NodeWriteT
 463 childWith uId pId (Node' NodeDocument txt v []) = node2table uId (Just pId) (Node' NodeDocument txt v [])
 464 childWith uId pId (Node' NodeContact  txt v []) = node2table uId (Just pId) (Node' NodeContact txt v [])
 465 childWith _   _   (Node' _        _   _ _) = panic "This NodeType can not be a child"
 466
 467
 468 -- TODO: remove hardcoded userId (with Reader)
 469 -- TODO: user Reader in the API and adapt this function
 470 userId = 1
 471
 472 mk :: Connection -> NodeType -> Maybe ParentId -> Text -> IO [Int]
 473 mk c nt pId name  = mk' c nt userId pId name
 474
 475 mk' :: Connection -> NodeType -> UserId -> Maybe ParentId -> Text -> IO [Int]
 476 mk' c nt uId pId name  = map fromIntegral <$> insertNodesWithParentR pId [node nt name hd pId uId] c
 477   where
 478     hd = Hyperdata (HyperdataUser (Just $ (pack . show) EN))
 479
 480 type Name = Text
 481
 482 mk'' :: NodeType -> Maybe ParentId -> UserId -> Name -> Cmd [Int]
 483 mk'' NodeUser Nothing uId name  = mkCmd $ \c -> mk' c NodeUser uId Nothing name
 484 mk'' NodeUser _       _   _     = panic "NodeUser can not has a parent"
 485 mk'' _        Nothing _   _     = panic "NodeType needs a parent"
 486 mk'' nt       pId     uId name  = mkCmd $ \c -> mk' c nt uId pId name
 487
 488 mkRoot :: UserId -> Cmd [Int]
 489 mkRoot uId = case uId > 0 of
 490                False -> panic "UserId <= 0"
 491                True  -> mk'' NodeUser Nothing uId ("User Node : " <> (pack . show) uId)
 492
 493 mkCorpus :: Maybe Name -> Maybe HyperdataCorpus -> ParentId -> UserId -> Cmd [Int]
 494 mkCorpus n h p u = insertNodesR' [nodeCorpusW n h p u]
 495
 496