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, defaultCorpus)
  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
  94 type DocId  = Int
  95 type UserId = Int
  96 type TypeId = Int
  97 ------------------------------------------------------------------------
  98 instance FromField HyperdataCorpus where
  99     fromField = fromField'
 100
 101 instance FromField HyperdataDocument where
 102     fromField = fromField'
 103
 104 instance FromField HyperdataDocumentV3 where
 105     fromField = fromField'
 106
 107 instance FromField HyperdataUser where
 108     fromField = fromField'
 109 ------------------------------------------------------------------------
 110 instance QueryRunnerColumnDefault PGJsonb HyperdataDocument where
 111   queryRunnerColumnDefault = fieldQueryRunnerColumn
 112
 113 instance QueryRunnerColumnDefault PGJsonb HyperdataDocumentV3 where
 114   queryRunnerColumnDefault = fieldQueryRunnerColumn
 115
 116 instance QueryRunnerColumnDefault PGJsonb HyperdataCorpus   where
 117   queryRunnerColumnDefault = fieldQueryRunnerColumn
 118
 119 instance QueryRunnerColumnDefault PGJsonb HyperdataUser     where
 120   queryRunnerColumnDefault = fieldQueryRunnerColumn
 121 ------------------------------------------------------------------------
 122
 123 fromField' :: (Typeable b, FromJSON b) => Field -> Maybe DB.ByteString -> Conversion b
 124 fromField' field mb = do
 125     v <- fromField field mb
 126     valueToHyperdata v
 127       where
 128           valueToHyperdata v = case fromJSON v of
 129              Success a  -> pure a
 130              Error _err -> returnError ConversionFailed field "cannot parse hyperdata"
 131
 132
 133 $(makeAdaptorAndInstance "pNode" ''NodePoly)
 134 $(makeLensesWith abbreviatedFields ''NodePoly)
 135
 136
 137 nodeTable :: Table NodeWrite NodeRead
 138 nodeTable = Table "nodes" (pNode Node { _node_id                = optional "id"
 139                                         , _node_typename        = required "typename"
 140                                         , _node_userId          = required "user_id"
 141                                         , _node_parentId        = required "parent_id"
 142                                         , _node_name            = required "name"
 143                                         , _node_date            = optional "date"
 144                                         , _node_hyperdata       = required "hyperdata"
 145                      --                   , node_titleAbstract   = optional "title_abstract"
 146                                         }
 147                             )
 148
 149
 150 nodeTable' :: Table (Maybe (Column PGInt4)
 151                     ,       Column PGInt4
 152                     ,       Column PGInt4
 153                     ,Maybe (Column PGInt4)
 154                     ,       Column PGText
 155                     ,Maybe (Column PGTimestamptz)
 156                     ,       Column PGJsonb
 157                     )
 158                     ((Column PGInt4)
 159                     ,       Column PGInt4
 160                     ,       Column PGInt4
 161                     ,       Column PGInt4
 162                     ,       Column PGText
 163                     ,(Column PGTimestamptz)
 164                     ,       Column PGJsonb
 165                     )
 166
 167 nodeTable' = Table "nodes" (PP.p7 ( optional "id"
 168                                , required "typename"
 169                                , required "user_id"
 170                                , optional "parent_id"
 171                                , required "name"
 172                                , optional "date"
 173                                , required "hyperdata"
 174                                )
 175                             )
 176
 177
 178 queryNodeTable :: Query NodeRead
 179 queryNodeTable = queryTable nodeTable
 180
 181 selectNode :: Column PGInt4 -> Query NodeRead
 182 selectNode id = proc () -> do
 183     row <- queryNodeTable -< ()
 184     restrict -< _node_id row .== id
 185     returnA -< row
 186
 187 runGetNodes :: Query NodeRead -> Cmd [Node Value]
 188 runGetNodes q = mkCmd $ \conn -> runQuery conn q
 189
 190 ------------------------------------------------------------------------
 191 selectRootUser :: UserId -> Query NodeRead
 192 selectRootUser userId = proc () -> do
 193     row <- queryNodeTable -< ()
 194     restrict -< _node_userId   row .== (pgInt4 userId)
 195     restrict -< _node_typename row .== (pgInt4 $ nodeTypeId NodeUser)
 196     returnA -< row
 197
 198 getRoot :: UserId -> Cmd [Node HyperdataUser]
 199 getRoot userId = mkCmd $ \conn -> runQuery conn (selectRootUser userId)
 200 ------------------------------------------------------------------------
 201
 202 -- | order by publication date
 203 -- Favorites (Bool), node_ngrams
 204 selectNodesWith :: ParentId     -> Maybe NodeType
 205                 -> Maybe Offset -> Maybe Limit   -> Query NodeRead
 206 selectNodesWith parentId maybeNodeType maybeOffset maybeLimit =
 207         --offset' maybeOffset $ limit' maybeLimit $ orderBy (asc (hyperdataDocument_Publication_date . node_hyperdata)) $ selectNodesWith' parentId typeId
 208         limit' maybeLimit $ offset' maybeOffset $ orderBy (asc _node_id) $ selectNodesWith' parentId maybeNodeType
 209
 210 selectNodesWith' :: ParentId -> Maybe NodeType -> Query NodeRead
 211 selectNodesWith' parentId maybeNodeType = proc () -> do
 212     node <- (proc () -> do
 213             row@(Node _ typeId _ parentId' _ _ _) <- queryNodeTable -< ()
 214             restrict -< parentId' .== (toNullable $ pgInt4 parentId)
 215
 216             let typeId' = maybe 0 nodeTypeId maybeNodeType
 217
 218             restrict -< if typeId' > 0
 219                            then typeId   .== (pgInt4 (typeId' :: Int))
 220                            else (pgBool True)
 221             returnA  -< row ) -< ()
 222     returnA -< node
 223
 224
 225 --type Cmd' a = forall m. (MonadReader env m, HasConnection env, MonadIO m) => m a
 226
 227
 228 -- deleteNode :: (MonadReader Connection m, MonadIO m) => Int -> m Int
 229 -- deleteNode :: Int -> Cmd' Int
 230
 231 deleteNode :: Int -> Cmd Int
 232 deleteNode n = mkCmd $ \conn ->
 233   fromIntegral <$> runDelete conn nodeTable
 234                  (\(Node n_id _ _ _ _ _ _) -> n_id .== pgInt4 n)
 235
 236 deleteNodes :: [Int] -> Cmd Int
 237 deleteNodes ns = mkCmd $ \conn ->
 238   fromIntegral <$> runDelete conn nodeTable
 239                    (\(Node n_id _ _ _ _ _ _) -> in_ ((map pgInt4 ns)) n_id)
 240
 241
 242 getNodesWith :: JSONB a => Connection -> Int -> proxy a -> Maybe NodeType
 243              -> Maybe Offset -> Maybe Limit -> IO [Node a]
 244 getNodesWith conn parentId _ nodeType maybeOffset maybeLimit =
 245     runQuery conn $ selectNodesWith
 246                   parentId nodeType maybeOffset maybeLimit
 247
 248
 249 -- NP check type
 250 getNodesWithParentId :: Int
 251                      -> Maybe Text -> Connection -> IO [Node Value]
 252 getNodesWithParentId n _ conn = runQuery conn $ selectNodesWithParentID n
 253
 254 getNodesWithParentId' :: Int
 255                      -> Maybe Text -> Connection -> IO [Node Value]
 256 getNodesWithParentId' n _ conn = runQuery conn $ selectNodesWithParentID n
 257
 258
 259 ------------------------------------------------------------------------
 260 getDocumentsV3WithParentId :: Connection -> Int -> IO [Node HyperdataDocumentV3]
 261 getDocumentsV3WithParentId conn n = runQuery conn $ selectNodesWith' n (Just NodeDocument)
 262
 263 getDocumentsWithParentId :: Connection -> Int -> IO [Node HyperdataDocument]
 264 getDocumentsWithParentId conn n = runQuery conn $ selectNodesWith' n (Just NodeDocument)
 265
 266 ------------------------------------------------------------------------
 267
 268
 269 selectNodesWithParentID :: Int -> Query NodeRead
 270 selectNodesWithParentID n = proc () -> do
 271     row@(Node _ _ _ parent_id _ _ _) <- queryNodeTable -< ()
 272     restrict -< if n > 0
 273                    then
 274                         parent_id .== (toNullable $ pgInt4 n)
 275                    else
 276                         isNull parent_id
 277     returnA -< row
 278
 279
 280 selectNodesWithType :: Column PGInt4 -> Query NodeRead
 281 selectNodesWithType type_id = proc () -> do
 282     row@(Node _ tn _ _ _ _ _) <- queryNodeTable -< ()
 283     restrict -< tn .== type_id
 284     returnA -< row
 285
 286 type JSONB = QueryRunnerColumnDefault PGJsonb
 287
 288 getNode :: JSONB a => Connection -> Int -> proxy a -> IO (Node a)
 289 getNode conn id _ = do
 290     fromMaybe (error $ "Node does node exist: " <> show id) . headMay <$> runQuery conn (limit 1 $ selectNode (pgInt4 id))
 291
 292
 293 getNodesWithType :: Connection -> Column PGInt4 -> IO [Node HyperdataDocument]
 294 getNodesWithType conn type_id = do
 295     runQuery conn $ selectNodesWithType type_id
 296
 297
 298 ------------------------------------------------------------------------
 299 -- WIP
 300 -- TODO Classe HasDefault where
 301 -- default NodeType = Hyperdata
 302 ------------------------------------------------------------------------
 303 type NodeWrite' = NodePoly (Maybe Int) Int Int (Maybe ParentId) Text (Maybe UTCTime) ByteString
 304 ------------------------------------------------------------------------
 305 defaultUser :: HyperdataUser
 306 defaultUser = HyperdataUser (Just $ (pack . show) EN)
 307
 308 nodeUserW :: Maybe Name -> Maybe HyperdataUser -> UserId -> NodeWrite'
 309 nodeUserW maybeName maybeHyperdata = node NodeUser name (Hyperdata user) Nothing
 310   where
 311     name = maybe "User" identity maybeName
 312     user = maybe defaultUser identity maybeHyperdata
 313 ------------------------------------------------------------------------
 314 defaultFolder :: HyperdataFolder
 315 defaultFolder = HyperdataFolder (Just "Markdown Description")
 316
 317 nodeFolderW :: Maybe Name -> Maybe HyperdataFolder -> ParentId -> UserId -> NodeWrite'
 318 nodeFolderW maybeName maybeFolder pid = node NodeFolder name (Hyperdata folder) (Just pid)
 319   where
 320     name   = maybe "Folder" identity maybeName
 321     folder = maybe defaultFolder identity maybeFolder
 322 ------------------------------------------------------------------------
 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