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